sbcl stuff

sbcl/.quicklisp/quicklisp/bundle-template.lisp

@@ -0,0 +1,161 @@
+(cl:in-package #:cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require "asdf")
+  (unless (find-package '#:asdf)
+    (error "ASDF could not be required")))
+
+(let ((indicator '#:ql-bundle-v1)
+      (searcher-name '#:ql-bundle-searcher)
+      (base (make-pathname :name nil :type nil
+                           :defaults #. (or *compile-file-truename*
+                                            *load-truename*))))
+  (labels ((file-lines (file)
+             (with-open-file (stream file)
+               (loop for line = (read-line stream nil)
+                     while line
+                     collect line)))
+           (relative (pathname)
+             (merge-pathnames pathname base))
+           (pathname-timestamp (pathname)
+             #+clisp
+             (nth-value 2 (ext:probe-pathname pathname))
+             #-clisp
+             (file-write-date pathname))
+           (system-table (table pathnames)
+             (dolist (pathname pathnames table)
+               (setf (gethash (pathname-name pathname) table)
+                     (relative pathname))))
+
+           (initialize-bundled-systems-table (table data-source)
+             (system-table table
+                           (mapcar (lambda (line)
+                                     (merge-pathnames line data-source))
+                                   (file-lines data-source))))
+
+           (local-projects-system-pathnames (data-source)
+             (let ((files (directory (merge-pathnames "**/*.asd"
+                                                      data-source))))
+               (stable-sort (sort files #'string< :key #'namestring)
+                            #'<
+                            :key (lambda (file)
+                                   (length (namestring file))))))
+           (initialize-local-projects-table (table data-source)
+             (system-table table (local-projects-system-pathnames data-source)))
+
+           (make-table (&key data-source init-function)
+             (let ((table (make-hash-table :test 'equalp)))
+               (setf (gethash "/data-source" table)
+                     data-source
+                     (gethash "/timestamp" table)
+                     (pathname-timestamp data-source)
+                     (gethash "/init" table)
+                     init-function)
+               table))
+
+           (tcall (table key &rest args)
+             (let ((fun (gethash key table)))
+               (unless (and fun (functionp fun))
+                 (error "Unknown function key ~S" key))
+               (apply fun args)))
+           (created-timestamp (table)
+             (gethash "/timestamp" table))
+           (data-source-timestamp (table)
+             (pathname-timestamp (data-source table)))
+           (data-source (table)
+             (gethash "/data-source" table))
+
+           (stalep (table)
+             ;; FIXME: Handle newly missing data sources?
+             (< (created-timestamp table)
+                (data-source-timestamp table)))
+           (meta-key-p (key)
+             (and (stringp key)
+                  (< 0 (length key))
+                  (char= (char key 0) #\/)))
+           (clear (table)
+             ;; Don't clear "/foo" keys
+             (maphash (lambda (key value)
+                        (declare (ignore value))
+                        (unless (meta-key-p key)
+                          (remhash key table)))
+                      table))
+           (initialize (table)
+             (tcall table "/init" table (data-source table))
+             (setf (gethash "/timestamp" table)
+                   (pathname-timestamp (data-source table)))
+             table)
+           (update (table)
+             (clear table)
+             (initialize table))
+           (lookup (system-name table)
+             (when (stalep table)
+               (update table))
+             (values (gethash system-name table)))
+
+           (search-function (system-name)
+             (let ((tables (get searcher-name indicator)))
+               (dolist (table tables)
+                 (let* ((result (lookup system-name table))
+                        (probed (and result (probe-file result))))
+                   (when probed
+                     (return probed))))))
+
+           (make-bundled-systems-table ()
+             (initialize
+              (make-table :data-source (relative "system-index.txt")
+                          :init-function #'initialize-bundled-systems-table)))
+           (make-bundled-local-projects-systems-table ()
+             (let ((data-source (relative "bundled-local-projects/system-index.txt")))
+               (when (probe-file data-source)
+                 (initialize
+                  (make-table :data-source data-source
+                              :init-function #'initialize-bundled-systems-table)))))
+           (make-local-projects-table ()
+             (initialize
+              (make-table :data-source (relative "local-projects/")
+                          :init-function #'initialize-local-projects-table)))
+
+           (=matching-data-sources (tables)
+             (let ((data-sources (mapcar #'data-source tables)))
+               (lambda (table)
+                 (member (data-source table) data-sources
+                         :test #'equalp))))
+
+           (check-for-existing-searcher (searchers)
+             (block done
+               (dolist (searcher searchers)
+                 (when (symbolp searcher)
+                   (let ((plist (symbol-plist searcher)))
+                     (loop for key in plist by #'cddr
+                           when
+                           (and (symbolp key) (string= key indicator))
+                           do
+                           (setf indicator key)
+                           (setf searcher-name searcher)
+                           (return-from done t)))))))
+
+           (clear-asdf (table)
+             (maphash (lambda (system-name pathname)
+                        (declare (ignore pathname))
+                        (asdf:clear-system system-name))
+                      table)))
+
+    (let ((existing (check-for-existing-searcher
+                     asdf:*system-definition-search-functions*)))
+      (let* ((local (make-local-projects-table))
+             (bundled-local-projects
+              (make-bundled-local-projects-systems-table))
+             (bundled (make-bundled-systems-table))
+             (new-tables (remove nil (list local
+                                           bundled-local-projects
+                                           bundled)))
+             (existing-tables (get searcher-name indicator))
+             (filter (=matching-data-sources new-tables)))
+        (setf (get searcher-name indicator)
+              (append new-tables (delete-if filter existing-tables)))
+        (map nil #'clear-asdf new-tables))
+      (unless existing
+        (setf (symbol-function searcher-name) #'search-function)
+        (push searcher-name asdf:*system-definition-search-functions*)))
+    t))

sbcl/.quicklisp/quicklisp/bundle.lisp

@@ -0,0 +1,362 @@
+;;;; bundle.lisp
+
+(in-package #:ql-bundle)
+
+;;; Bundling is taking a set of Quicklisp-provided systems and
+;;; creating a directory structure and metadata in which those systems
+;;; can be loaded without involving Quicklisp.
+;;;
+;;; This works for systems provided directly Quicklisp, or systems in
+;;; the Quicklisp local-projects directories (if
+;;; :include-local-projects is specified).
+
+(defgeneric find-system (system bundle))
+(defgeneric add-system (system bundle))
+(defgeneric ensure-system (system bundle))
+
+(defgeneric find-release (relase bundle))
+(defgeneric add-release (release bundle))
+(defgeneric ensure-release (release bundle))
+
+(defgeneric write-loader-script (bundle stream))
+(defgeneric write-system-index (bundle stream))
+
+(defgeneric unpack-release (release target))
+(defgeneric unpack-releases (bundle target))
+
+(defgeneric write-bundle (bundle target))
+
+(defvar *ignored-systems*
+  (list "asdf")
+  "Systems that might appear in depends-on lists in Quicklisp, but
+  which can't be bundled.")
+
+(defvar *bundle-progress-output*
+  (make-synonym-stream '*trace-output*)
+  "Informative output related to creating the bundle is sent to this
+  stream.")
+
+;;; Implementation
+
+;;; Conditions
+
+(define-condition bundle-error (error) ())
+
+(define-condition object-not-found (bundle-error)
+  ((name
+    :initarg :name
+    :reader object-not-found-name)
+   (type
+    :initarg :type
+    :reader object-not-found-type))
+  (:report
+   (lambda (condition stream)
+     (format stream "~A ~S not found"
+             (object-not-found-type condition)
+             (object-not-found-name condition))))
+  (:default-initargs
+   :type "Object"))
+
+(define-condition system-not-found (object-not-found)
+  ((name
+    :reader system-not-found-system))
+  (:default-initargs
+   :type "System"))
+
+(define-condition release-not-found (object-not-found)
+  ()
+  (:default-initargs
+   :type "Release"))
+
+(define-condition bundle-directory-exists (bundle-error)
+  ((directory
+    :initarg :directory
+    :reader bundle-directory-exists-directory))
+  (:report
+   (lambda (condition stream)
+     (format stream "Bundle directory ~A already exists"
+             (bundle-directory-exists-directory condition)))))
+
+
+(defun iso8601-time-stamp (&optional (time (get-universal-time)))
+  (multiple-value-bind (second minute hour day month year)
+      (decode-universal-time time 0)
+     (format nil "~4,'0D-~2,'0D-~2,'0DT~
+                  ~2,'0D:~2,'0D:~2,'0DZ"
+             year month day
+             hour minute second)))
+
+
+(defclass bundle ()
+  ((requested-systems
+    :initarg :requested-systems
+    :reader requested-systems
+    :documentation "Names of the systems requested directly for
+    bundling.")
+   (creation-time
+    :initarg :creation-time
+    :reader creation-time)
+   (release-table
+    :initarg :release-table
+    :reader release-table)
+   (system-table
+    :initarg :system-table
+    :reader system-table))
+  (:default-initargs
+   :requested-systems nil
+   :creation-time (iso8601-time-stamp)
+   :release-table (make-hash-table :test 'equalp)
+   :system-table (make-hash-table :test 'equalp)))
+
+(defmethod print-object ((bundle bundle) stream)
+  (print-unreadable-object (bundle stream :type t)
+    (format stream "~D release~:P, ~D system~:P"
+            (hash-table-count (release-table bundle))
+            (hash-table-count (system-table bundle)))))
+
+(defmethod provided-releases ((bundle bundle))
+  (let ((releases '()))
+    (maphash (lambda (name release)
+               (declare (ignore name))
+               (push release releases))
+             (release-table bundle))
+    (sort releases 'string< :key 'name)))
+
+(defmethod provided-systems ((bundle bundle))
+  (sort (mapcan #'provided-systems (provided-releases bundle))
+        'string<
+        :key 'name))
+
+(defmethod find-system (name (bundle bundle))
+  (values (gethash name (system-table bundle))))
+
+(defmethod add-system (name (bundle bundle))
+  (let ((system (ql-dist:find-system name)))
+    (unless system
+      (error 'system-not-found
+             :name name))
+    (ensure-release (name (release system)) bundle)
+    system))
+
+(defmethod ensure-system (name (bundle bundle))
+  (or (find-system name bundle)
+      (add-system name bundle)))
+
+(defmethod find-release (name (bundle bundle))
+  (values (gethash name (release-table bundle))))
+
+(defmethod add-release (name (bundle bundle))
+  (let ((release (ql-dist:find-release name)))
+    (unless release
+      (error 'release-not-found
+             :name name))
+    (setf (gethash (name release) (release-table bundle)) release)
+    (let ((system-table (system-table bundle)))
+      (dolist (system (provided-systems release))
+        (setf (gethash (name system) system-table) system)))
+    release))
+
+(defmethod ensure-release (name (bundle bundle))
+  (or (find-release name bundle)
+      (add-release name bundle)))
+
+
+(defun add-systems-recursively (names bundle)
+  (with-consistent-dists
+    (labels ((add-one (name)
+               (unless (member name *ignored-systems* :test 'equalp)
+                 (let ((system
+                        (restart-case
+                            (ensure-system name bundle)
+                          (omit ()
+                            :report "Ignore this system and omit it from the bundle."))))
+                   (when system
+                     (dolist (required-system-name (required-systems system))
+                       (add-one required-system-name)))))))
+      (map nil #'add-one names)))
+  bundle)
+
+
+(defmethod unpack-release (release target)
+  (let ((*default-pathname-defaults* (truename
+                                      (ensure-directories-exist target)))
+        (archive (ensure-local-archive-file release))
+        (temp-tar (ensure-directories-exist
+                   (ql-setup:qmerge "tmp/bundle.tar"))))
+    (ql-gunzipper:gunzip archive temp-tar)
+    (ql-minitar:unpack-tarball temp-tar :directory "software/")
+    (delete-file temp-tar)
+    release))
+
+(defmethod unpack-releases ((bundle bundle) target)
+  (dolist (release (provided-releases bundle))
+    (unpack-release release target))
+  bundle)
+
+(defmethod write-system-index ((bundle bundle) stream)
+  (dolist (release (provided-releases bundle))
+    ;; Working with strings, here, intentionally not with pathnames
+    (let ((prefix (concatenate 'string "software/" (prefix release))))
+      (dolist (system-file (system-files release))
+        (format stream "~A/~A~%" prefix system-file)))))
+
+(defmethod write-loader-script ((bundle bundle) stream)
+  (let ((template-lines
+         (load-time-value
+          (with-open-file (stream #. (merge-pathnames "bundle-template"
+                                                      (or *compile-file-truename*
+                                                          *load-truename*)))
+            (loop for line = (read-line stream nil)
+                  while line collect line)))))
+    (dolist (line template-lines)
+      (write-line line stream))))
+
+(defun coerce-to-directory (pathname)
+  ;; Cribbed from quicklisp-bootstrap/quicklisp.lisp
+  (let ((name (file-namestring pathname)))
+    (if (or (null name)
+            (equal name ""))
+        pathname
+        (make-pathname :defaults pathname
+                       :name nil
+                       :type nil
+                       :directory (append (pathname-directory pathname)
+                                          (list name))))))
+
+(defun bundle-metadata-plist (bundle)
+  (list :creation-time (creation-time bundle)
+        :requested-systems (requested-systems bundle)
+        :lisp-info (list :machine-instance (machine-instance)
+                         :machine-type (machine-type)
+                         :machine-version (machine-version)
+                         :lisp-implementation-type (lisp-implementation-type)
+                         :lisp-implementation-version (lisp-implementation-version))
+        :quicklisp-info (list :home (namestring ql:*quicklisp-home*)
+                              :local-project-directories
+                              (mapcar 'namestring ql:*local-project-directories*)
+                              :dists
+                              (loop for dist in (enabled-dists)
+                                    collect (list :name (name dist)
+                                                  :dist-url
+                                                  (canonical-distinfo-url dist)
+                                                  :version (version dist))))))
+
+(defmethod write-bundle ((bundle bundle) target)
+  (unpack-releases bundle target)
+  (let ((index-file (merge-pathnames "system-index.txt" target))
+        (loader-file (merge-pathnames "bundle.lisp" target))
+        (local-projects (merge-pathnames "local-projects/" target))
+        (metadata-file (merge-pathnames "bundle-info.sexp" target)))
+    (ensure-directories-exist local-projects)
+    (with-open-file (stream index-file :direction :output
+                            :if-exists :supersede)
+      (write-system-index bundle stream))
+    (with-open-file (stream loader-file :direction :output
+                            :if-exists :supersede)
+      (write-loader-script bundle stream))
+    (with-open-file (stream metadata-file :direction :output
+                            :if-exists :supersede)
+      (with-standard-io-syntax
+        (let ((*print-pretty* t))
+          (prin1 (bundle-metadata-plist bundle) stream)
+          (terpri stream))))
+    (probe-file loader-file)))
+
+
+(defun copy-file (from-file to-file)
+  (with-open-file (from-stream from-file :element-type '(unsigned-byte 8)
+                               :if-does-not-exist nil)
+    (when from-stream
+      (let ((buffer (make-array 10000 :element-type '(unsigned-byte 8))))
+        (with-open-file (to-stream to-file
+                                   :direction :output
+                                   :if-exists :supersede
+                                   :element-type '(unsigned-byte 8))
+          (loop
+            (let ((end-index (read-sequence buffer from-stream)))
+              (when (zerop end-index)
+                (return to-file))
+              (write-sequence buffer to-stream :end end-index))))))))
+
+(defun copy-directory-tree (from-directory to-directory)
+  ;; Use the truename here to ensure that relative pathnames match up
+  ;; properly. For example, on SBCL, "~/foo/bar/" entries are not
+  ;; relative to "/home/baz/foo/bar/" entries.
+  (setf from-directory (truename from-directory))
+  (map-directory-tree
+   from-directory
+   (lambda (from-pathname)
+     (when (probe-file from-pathname)
+       (let* ((relative (enough-namestring from-pathname from-directory))
+              (relative-directory (pathname-directory relative))
+              (to-pathname (merge-pathnames relative to-directory)))
+         (unless (or (null relative-directory)
+                     (eql (first relative-directory)
+                          :relative))
+           (error "Expected relative pathname to copy from ~A ~
+                   - bad symlink? - ~S"
+                  from-pathname
+                  relative))
+         (ensure-directories-exist to-pathname)
+         (copy-file from-pathname to-pathname))))))
+
+(defun copy-local-projects-directories (local-projects-directories
+                                        to-directory)
+  "Copy the local-projects directories to TO-DIRECTORY. Each one gets
+  a distinct subdirectory."
+  (loop for prefix from 0
+        for prefix-directory = (make-pathname :directory
+                                              (list :relative
+                                                    (format nil "~4,'0X" prefix)))
+        for from-directory in local-projects-directories
+        for real-to-directory = (merge-pathnames prefix-directory to-directory)
+        do
+        (format *bundle-progress-output*
+                "~&; Copying ~A to bundle..." from-directory )
+        (force-output *bundle-progress-output*)
+        (ensure-directories-exist real-to-directory)
+        (copy-directory-tree from-directory real-to-directory)
+        (format *bundle-progress-output* "done.~%")
+        (force-output *bundle-progress-output*)))
+
+
+(defun ql:bundle-systems (system-names
+                          &key include-local-projects to (overwrite t))
+  "In the directory TO, construct a self-contained bundle of libraries
+based on SYSTEM-NAMES. For each system named, and its recursive
+required systems, unpack its release archive in TO/software/, and
+write a system index, compatible with the output of
+QL:WRITE-ASDF-MANIFEST-FILE, to TO/system-index.txt. Write a loader
+script to TO/bundle.lisp that, when loaded via CL:LOAD, configures
+ASDF to load systems from the bundle before any other system.
+
+SYSTEM-NAMES must name systems provided directly by Quicklisp.
+
+If INCLUDE-LOCAL-PROJECTS is true, each directory in
+QL:*LOCAL-PROJECT-DIRECTORIES* is copied into the bundle and loaded
+before any of the other bundled systems."
+  (unless to
+    (error "TO argument must be provided"))
+  (let* ((bundle (make-instance 'bundle
+                                :requested-systems system-names))
+         (to (coerce-to-directory to))
+         (software (merge-pathnames "software/" to)))
+    (when (and (probe-directory to)
+               (not overwrite))
+      (cerror "Overwrite it"
+              'bundle-directory-exists
+              :directory to))
+    (when (probe-directory software)
+      (delete-directory-tree software))
+    (add-systems-recursively system-names bundle)
+    (let ((bundled-local-projects (merge-pathnames "bundled-local-projects/"
+                                                   to)))
+      (when include-local-projects
+        (when (probe-directory bundled-local-projects)
+          (delete-directory-tree bundled-local-projects))
+        (copy-local-projects-directories ql:*local-project-directories*
+                                         bundled-local-projects)
+        (ensure-directories-exist bundled-local-projects)
+        (ql::make-system-index bundled-local-projects)))
+    (values (write-bundle bundle to)
+            bundle)))

sbcl/.quicklisp/quicklisp/cdb.lisp

@@ -0,0 +1,356 @@
+;;;; cdb.lisp
+
+(in-package #:ql-cdb)
+
+(defconstant +initial-hash-value+ 5381)
+
+(defun cdb-hash (octets)
+  "http://cr.yp.to/cdb/cdb.txt"
+  (declare (type (simple-array (unsigned-byte 8) (*)) octets)
+           (optimize speed))
+  (let ((h +initial-hash-value+))
+    (declare (type (unsigned-byte 32) h))
+    (dotimes (i (length octets) h)
+      (let ((c (aref octets i)))
+        (setf h (logand #xFFFFFFFF (+ h (ash h 5))))
+        (setf h (logxor h c))))))
+
+(defun make-growable-vector (&key
+                             (size 10) (element-type t))
+  (make-array size :fill-pointer 0 :adjustable t :element-type element-type))
+
+(defun make-octet-vector (size)
+  (make-array size :element-type '(unsigned-byte 8)))
+
+(defun encode-string (string)
+  "Do a bare-bones ASCII encoding of STRING."
+  (map-into (make-octet-vector (length string))
+            'char-code
+            string))
+
+(defun decode-octets (octets)
+  "Do a bare-bones ASCII decoding of OCTETS."
+  (map-into (make-string (length octets))
+            'code-char
+            octets))
+
+(defun read-cdb-u32 (stream)
+  (logand #xFFFFFFFF
+          (logior (ash (read-byte stream) 0)
+                  (ash (read-byte stream) 8)
+                  (ash (read-byte stream) 16)
+                  (ash (read-byte stream) 24))))
+
+(defun lookup-record-at (position key stream)
+  (file-position stream position)
+  (let ((key-size (read-cdb-u32 stream))
+        (value-size (read-cdb-u32 stream)))
+    (when (= key-size (length key))
+      (let ((test-key (make-octet-vector key-size)))
+        (when (/= key-size (read-sequence test-key stream))
+          (error "Could not read record key of size ~D from cdb stream"
+                 key-size))
+        (unless (mismatch test-key key :test #'=)
+          (let ((value (make-octet-vector value-size)))
+            (if (= value-size (read-sequence value stream))
+                value
+                (error "Could not read record value of size ~D from cdb stream"
+                       value-size))))))))
+
+(defun table-slot-lookup (key hash table-position
+                          initial-slot slot-count stream)
+  (let ((slot initial-slot))
+    (loop
+      (file-position stream (+ table-position (* slot 8)))
+      (let ((test-hash (read-cdb-u32 stream))
+            (record-position (read-cdb-u32 stream)))
+        (when (zerop record-position)
+          (return))
+        (when (= hash test-hash)
+          (let ((value (lookup-record-at record-position key stream)))
+            (when value
+              (return value)))))
+      (setf slot (mod (1+ slot) slot-count)))))
+
+(defun stream-lookup (key stream)
+  (let* ((hash (cdb-hash key))
+         (pointer-index (logand #xFF hash)))
+    (file-position stream (* pointer-index 8))
+    (let ((table-position (read-cdb-u32 stream))
+          (slot-count (read-cdb-u32 stream)))
+      (when (plusp slot-count)
+        (let ((initial-slot (mod (ash hash -8) slot-count)))
+          (table-slot-lookup key hash
+                             table-position initial-slot slot-count stream))))))
+
+(defun %lookup (key cdb)
+  "Return the value for KEY in CDB, or NIL if no matching key is
+found. CDB should be a pathname or an open octet stream. The key
+should be a vector of octets. The returned value will be a vector of
+octets."
+  (if (streamp cdb)
+      (stream-lookup key cdb)
+      (with-open-file (stream cdb :element-type '(unsigned-byte 8))
+        (stream-lookup key stream))))
+
+(defun lookup (key cdb)
+  "Return the value for KEY in CDB, or NIL if no matching key is
+found. CDB should be a pathname or an open octet stream. The key
+should be an ASCII-encodable string. The returned value will be a
+string."
+  (let ((value (%lookup (encode-string key) cdb)))
+    (when value
+      (decode-octets value))))
+
+(defun stream-map-cdb (function stream)
+  (labels ((map-one-slot (i)
+             (file-position stream (* i 8))
+             (let ((table-position (read-cdb-u32 stream))
+                   (slot-count (read-cdb-u32 stream)))
+               (when (plusp slot-count)
+                 (map-one-table table-position slot-count))))
+           (map-one-table (position count)
+             (dotimes (i count)
+               (file-position stream (+ position (* i 8)))
+               (let ((hash (read-cdb-u32 stream))
+                     (position (read-cdb-u32 stream)))
+                 (declare (ignore hash))
+                 (when (plusp position)
+                   (map-record position)))))
+           (map-record (position)
+             (file-position stream position)
+             (let* ((key-size (read-cdb-u32 stream))
+                    (value-size (read-cdb-u32 stream))
+                    (key (make-octet-vector key-size))
+                    (value (make-octet-vector value-size)))
+               (read-sequence key stream)
+               (read-sequence value stream)
+               (funcall function key value))))
+    (dotimes (i 256)
+      (map-one-slot i))))
+
+(defun %map-cdb (function cdb)
+  "Call FUNCTION once with each key and value in CDB."
+  (if (streamp cdb)
+      (stream-map-cdb function cdb)
+      (with-open-file (stream cdb :element-type '(unsigned-byte 8))
+        (stream-map-cdb function stream))))
+
+(defun map-cdb (function cdb)
+  (%map-cdb (lambda (key value)
+              (funcall function
+                       (decode-octets key)
+                       (decode-octets value)))
+            cdb))
+
+
+;;; Writing CDB files
+
+(defun write-cdb-u32 (u32 stream)
+  "Write an (unsigned-byte 32) value to STREAM in little-endian order."
+  (write-byte (ldb (byte 8 0) u32) stream)
+  (write-byte (ldb (byte 8 8) u32) stream)
+  (write-byte (ldb (byte 8 16) u32) stream)
+  (write-byte (ldb (byte 8 24) u32) stream))
+
+(defclass record-pointer ()
+  ((hash-value
+    :initarg :hash-value
+    :accessor hash-value
+    :documentation "The hash value of the record key.")
+   (record-position
+    :initarg :record-position
+    :accessor record-position
+    :documentation "The file position at which the record is stored."))
+  (:default-initargs
+   :hash-value 0
+   :record-position 0)
+  (:documentation "Every key/value record written to a CDB has a
+  corresponding record pointer, which tracks the key's hash value and
+  the record's position in the data file. When all records have been
+  written to the file, these record pointers are organized into hash
+  tables at the end of the cdb file."))
+
+(defmethod print-object ((record-pointer record-pointer) stream)
+  (print-unreadable-object (record-pointer stream :type t)
+    (format stream "~8,'0X@~:D"
+            (hash-value record-pointer)
+            (record-position record-pointer))))
+
+(defvar *empty-record-pointer* (make-instance 'record-pointer))
+
+
+(defclass hash-table-bucket ()
+  ((table-position
+    :initarg :table-position
+    :accessor table-position
+    :documentation "The file position at which this table
+    is (eventually) slotted.")
+   (entries
+    :initarg :entries
+    :accessor entries
+    :documentation "A vector of record-pointers."))
+  (:default-initargs
+   :table-position 0
+   :entries (make-growable-vector))
+  (:documentation "During construction of the CDB, record pointers are
+  accumulated into one of 256 hash table buckets, depending on the low
+  8 bits of the hash value of the key. At the end of record writing,
+  these buckets are used to write out hash table vectors at the end of
+  the file, and write pointers to the hash table vectors at the start
+  of the file."))
+
+(defgeneric entry-count (object)
+  (:method ((object hash-table-bucket))
+    (length (entries object))))
+
+(defgeneric slot-count (object)
+  (:method ((object hash-table-bucket))
+    (* (entry-count object) 2)))
+
+(defun bucket-hash-vector (bucket)
+  "Create a hash vector for a bucket. A hash vector has 2x the entries
+of the bucket, and is initialized to an empty record pointer. The high
+24 bits of the hash value of a record pointer, mod the size of the
+vector, is used as a starting slot, and the vector is walked (wrapping
+at the end) to find the first free slot for positioning each record
+pointer entry."
+  (let* ((size (slot-count bucket))
+         (vector (make-array size :initial-element nil)))
+    (flet ((slot (record)
+             (let ((index (mod (ash (hash-value record) -8) size)))
+               (loop
+                 (unless (aref vector index)
+                   (return (setf (aref vector index) record)))
+                 (setf index (mod (1+ index) size))))))
+      (map nil #'slot (entries bucket)))
+    (nsubstitute *empty-record-pointer* nil vector)))
+
+(defmethod print-object ((bucket hash-table-bucket) stream)
+  (print-unreadable-object (bucket stream :type t)
+    (format stream "~D entr~:@P" (entry-count bucket))))
+
+
+(defclass cdb-writer ()
+  ((buckets
+    :initarg :buckets
+    :accessor buckets)
+   (end-of-records-position
+    :initarg :end-of-records-position
+    :accessor end-of-records-position)
+   (output
+    :initarg :output
+    :accessor output))
+  (:default-initargs
+   :end-of-records-position 2048
+   :buckets (map-into (make-array 256)
+                      (lambda () (make-instance 'hash-table-bucket)))))
+
+
+(defun add-record (key value cdb-writer)
+  "Add KEY and VALUE to a cdb file. KEY and VALUE should both
+be (unsigned-byte 8) vectors."
+  (let* ((output (output cdb-writer))
+         (hash-value (cdb-hash key))
+         (bucket-index (logand #xFF hash-value))
+         (bucket (aref (buckets cdb-writer) bucket-index))
+         (record-position (file-position output))
+         (record-pointer (make-instance 'record-pointer
+                                        :record-position record-position
+                                        :hash-value hash-value)))
+    (vector-push-extend record-pointer (entries bucket))
+    (write-cdb-u32 (length key) output)
+    (write-cdb-u32 (length value) output)
+    (write-sequence key output)
+    (write-sequence value output)
+    (force-output output)
+    (incf (end-of-records-position cdb-writer)
+          (+ 8 (length key) (length value)))))
+
+(defun write-bucket-hash-table (bucket stream)
+  "Write BUCKET's hash table vector to STREAM."
+  (map nil
+       (lambda (pointer)
+         (write-cdb-u32 (hash-value pointer) stream)
+         (write-cdb-u32 (record-position pointer) stream))
+       (bucket-hash-vector bucket)))
+
+(defun write-hash-tables (cdb-writer)
+  "Write the traililng hash tables to the end of the cdb
+file. Initializes the position of the buckets in the process."
+  (let ((stream (output cdb-writer)))
+    (map nil
+         (lambda (bucket)
+           (setf (table-position bucket) (file-position stream))
+           (write-bucket-hash-table bucket stream))
+         (buckets cdb-writer))))
+
+(defun write-pointers (cdb-writer)
+  "Write the leading hash table pointers to the beginning of the cdb
+file. Must be called after WRITE-HASH-TABLES, or the positions won't
+be available."
+  (let ((stream (output cdb-writer)))
+    (file-position stream :start)
+    (map nil
+         (lambda (bucket)
+           (let ((position (table-position bucket))
+                 (count (slot-count bucket)))
+             (when (zerop position)
+               (error "Table positions not initialized correctly"))
+             (write-cdb-u32 position stream)
+             (write-cdb-u32 count stream)))
+         (buckets cdb-writer))))
+
+(defun finish-cdb-writer (cdb-writer)
+  "Write the trailing hash tables and leading table pointers to the
+cdb file."
+  (write-hash-tables cdb-writer)
+  (write-pointers cdb-writer)
+  (force-output (output cdb-writer)))
+
+
+(defvar *pointer-padding* (make-array 2048 :element-type '( unsigned-byte 8)))
+
+(defun call-with-output-to-cdb (cdb-pathname temp-pathname fun)
+  "Call FUN with one argument, a CDB-WRITER instance to which records
+can be added with ADD-RECORD."
+  (with-open-file (stream temp-pathname
+                          :direction :output
+                          :element-type '(unsigned-byte 8)
+                          :if-exists :supersede)
+    (let ((cdb (make-instance 'cdb-writer :output stream)))
+      (write-sequence *pointer-padding* stream)
+      (funcall fun cdb)
+      (finish-cdb-writer cdb)))
+  (values (rename-file temp-pathname cdb-pathname)))
+
+(defmacro with-output-to-cdb ((cdb file temp-file) &body body)
+  "Evaluate BODY with CDB bound to a CDB-WRITER object. The CDB in
+progress is written to TEMP-FILE, and then when the CDB is
+successfully written, TEMP-FILE is renamed to FILE. For atomic
+operation, FILE and TEMP-FILE must be on the same filesystem."
+  `(call-with-output-to-cdb ,file ,temp-file
+                            (lambda (,cdb)
+                              ,@body)))
+
+
+;;; Index file (systems.txt, releases.txt) conversion
+
+(defun convert-index-file (index-file
+                           &key (cdb-file (make-pathname :type "cdb"
+                                                         :defaults index-file))
+                             (index 0))
+  (with-open-file (stream index-file)
+    (let ((header (read-line stream)))
+      (unless (and (plusp (length header))
+                   (char= (char header 0) #\#))
+        (error "Bad header line in ~A -- ~S"
+               index-file header)))
+    (with-output-to-cdb (cdb cdb-file (make-pathname :type "cdb-tmp"
+                                                     :defaults cdb-file))
+      (loop for line = (read-line stream nil)
+            for words = (and line (ql-util:split-spaces line))
+            while line do
+            (add-record (encode-string (elt words index))
+                        (encode-string line)
+                        cdb)))))

sbcl/.quicklisp/quicklisp/client-info.lisp

@@ -0,0 +1,262 @@
+;;;; client-info.lisp
+
+(in-package #:quicklisp-client)
+
+(defparameter *client-base-url* "http://beta.quicklisp.org/")
+
+(defgeneric info-equal (info1 info2)
+  (:documentation "Return TRUE if INFO1 and INFO2 are 'equal' in some
+  important sense."))
+
+;;; Information for checking the validity of files fetched for
+;;; installing/updating the client code.
+
+(defclass client-file-info ()
+  ((plist-key
+    :initarg :plist-key
+    :reader plist-key)
+   (file-url
+    :initarg :url
+    :reader file-url)
+   (name
+    :reader name
+    :initarg :name)
+   (size
+    :initarg :size
+    :reader size)
+   (md5
+    :reader md5
+    :initarg :md5)
+   (sha256
+    :reader sha256
+    :initarg :sha256)
+   (plist
+    :reader plist
+    :initarg :plist)))
+
+(defmethod print-object ((info client-file-info) stream)
+  (print-unreadable-object (info stream :type t)
+    (format stream "~S ~D ~S"
+            (name info)
+            (size info)
+            (md5 info))))
+
+(defmethod info-equal ((info1 client-file-info) (info2 client-file-info))
+  (and (eql (size info1) (size info2))
+       (equal (name info1) (name info2))
+       (equal (md5 info1) (md5 info2))))
+
+(defclass asdf-file-info (client-file-info)
+  ()
+  (:default-initargs
+   :plist-key :asdf
+   :name "asdf.lisp"))
+
+(defclass setup-file-info (client-file-info)
+  ()
+  (:default-initargs
+   :plist-key :setup
+   :name "setup.lisp"))
+
+(defclass client-tar-file-info (client-file-info)
+  ()
+  (:default-initargs
+   :plist-key :client-tar
+   :name "quicklisp.tar"))
+
+(define-condition invalid-client-file (error)
+  ((file
+    :initarg :file
+    :reader invalid-client-file-file)))
+
+(define-condition badly-sized-client-file (invalid-client-file)
+  ((expected-size
+    :initarg :expected-size
+    :reader badly-sized-client-file-expected-size)
+   (actual-size
+    :initarg :actual-size
+    :reader badly-sized-client-file-actual-size))
+  (:report (lambda (condition stream)
+             (format stream "Unexpected file size for ~A ~
+                             - expected ~A but got ~A"
+                     (invalid-client-file-file condition)
+                     (badly-sized-client-file-expected-size condition)
+                     (badly-sized-client-file-actual-size condition)))))
+
+(defun check-client-file-size (file expected-size)
+  (let ((actual-size (file-size file)))
+    (unless (eql expected-size actual-size)
+      (error 'badly-sized-client-file
+             :file file
+             :expected-size expected-size
+             :actual-size actual-size))))
+
+;;; TODO: check cryptographic digests too.
+
+(defgeneric check-client-file (file client-file-info)
+  (:documentation
+   "Signal an INVALID-CLIENT-FILE error if FILE does not match the
+   metadata in CLIENT-FILE-INFO.")
+  (:method (file client-file-info)
+    (check-client-file-size file (size client-file-info))
+    client-file-info))
+
+;;; Structuring and loading information about the Quicklisp client
+;;; code
+
+(defclass client-info ()
+  ((setup-info
+    :reader setup-info
+    :initarg :setup-info)
+   (asdf-info
+    :reader asdf-info
+    :initarg :asdf-info)
+   (client-tar-info
+    :reader client-tar-info
+    :initarg :client-tar-info)
+   (canonical-client-info-url
+    :reader canonical-client-info-url
+    :initarg :canonical-client-info-url)
+   (version
+    :reader version
+    :initarg :version)
+   (subscription-url
+    :reader subscription-url
+    :initarg :subscription-url)
+   (plist
+    :reader plist
+    :initarg :plist)
+   (source-file
+    :reader source-file
+    :initarg :source-file)))
+
+(defmethod print-object ((client-info client-info) stream)
+  (print-unreadable-object (client-info stream :type t)
+    (prin1 (version client-info) stream)))
+
+(defmethod available-versions-url ((info client-info))
+  (make-versions-url (subscription-url info)))
+
+(defgeneric extract-client-file-info (file-info-class plist)
+  (:method (file-info-class plist)
+    (let* ((instance (make-instance file-info-class))
+           (key (plist-key instance))
+           (file-info-plist (getf plist key)))
+      (unless file-info-plist
+        (error "Missing client-info data for ~S" key))
+      (destructuring-bind (&key url size md5 sha256 &allow-other-keys)
+          file-info-plist
+        (unless (and url size md5 sha256)
+          (error "Missing client-info data for ~S" key))
+        (reinitialize-instance instance
+                               :plist file-info-plist
+                               :url url
+                               :size size
+                               :md5 md5
+                               :sha256 sha256)))))
+
+(defun format-client-url (path &rest format-arguments)
+  (if format-arguments
+      (format nil "~A~{~}" *client-base-url* path format-arguments)
+      (format nil "~A~A" *client-base-url* path)))
+
+(defun client-info-url-from-version (version)
+  (format-client-url "client/~A/client-info.sexp" version))
+
+(define-condition invalid-client-info (error)
+  ((plist
+    :initarg plist
+    :reader invalid-client-info-plist)))
+
+(defun load-client-info (file)
+  (let ((plist (safely-read-file file)))
+    (destructuring-bind (&key subscription-url
+                              version
+                              canonical-client-info-url
+                              &allow-other-keys)
+        plist
+      (make-instance 'client-info
+                     :setup-info (extract-client-file-info 'setup-file-info
+                                                           plist)
+                     :asdf-info (extract-client-file-info 'asdf-file-info
+                                                          plist)
+                     :client-tar-info
+                     (extract-client-file-info 'client-tar-file-info
+                                               plist)
+                     :canonical-client-info-url canonical-client-info-url
+                     :version version
+                     :subscription-url subscription-url
+                     :plist plist
+                     :source-file (probe-file file)))))
+
+(defun mock-client-info ()
+  (flet ((mock-client-file-info (class)
+           (make-instance class
+                          :size 0
+                          :url ""
+                          :md5 ""
+                          :sha256 ""
+                          :plist nil)))
+    (make-instance 'client-info
+                   :version ql-info:*version*
+                   :subscription-url
+                   (format-client-url "client/quicklisp.sexp")
+                   :setup-info (mock-client-file-info 'setup-file-info)
+                   :asdf-info (mock-client-file-info 'asdf-file-info)
+                   :client-tar-info (mock-client-file-info
+                                     'client-tar-file-info))))
+
+(defun fetch-client-info (url)
+  (let ((info-file (qmerge "tmp/client-info.sexp")))
+    (delete-file-if-exists info-file)
+    (fetch url info-file :quietly t)
+    (handler-case
+        (load-client-info info-file)
+      ;; FIXME: So many other things could go wrong here; I think it
+      ;; would be nice to catch and report them clearly as bogus URLs
+      (invalid-client-info ()
+        (error "Invalid client info URL -- ~A" url)))))
+
+(defun local-client-info ()
+  (let ((info-file (qmerge "client-info.sexp")))
+    (if (probe-file info-file)
+        (load-client-info info-file)
+        (progn
+          (warn "Missing client-info.sexp, using mock info")
+          (mock-client-info)))))
+
+(defun newest-client-info (&optional (info (local-client-info)))
+  (let ((latest (subscription-url info)))
+    (when latest
+      (fetch-client-info latest))))
+
+(defun client-version-lessp (client-info-1 client-info-2)
+  (string-lessp (version client-info-1)
+                (version client-info-2)))
+
+(defun client-version ()
+  "Return the version for the current local client installation. May
+or may not be suitable for passing as the :VERSION argument to
+INSTALL-CLIENT, depending on if it's a standard Quicklisp-provided
+client."
+  (version (local-client-info)))
+
+(defun client-url ()
+  "Return an URL suitable for passing as the :URL argument to
+INSTALL-CLIENT for the current local client installation."
+  (canonical-client-info-url (local-client-info)))
+
+(defun available-client-versions ()
+  (let ((url (available-versions-url (local-client-info)))
+        (temp-file (qmerge "tmp/client-versions.sexp")))
+    (when url
+      (handler-case
+          (progn
+            (maybe-fetch-gzipped url temp-file)
+            (prog1
+                (with-open-file (stream temp-file)
+                  (safely-read stream))
+              (delete-file-if-exists temp-file)))
+        (unexpected-http-status (condition)
+          (unless (url-not-suitable-error-p condition)
+            (error condition)))))))

sbcl/.quicklisp/quicklisp/client-update.lisp

@@ -0,0 +1,106 @@
+;;;; client-update.lisp
+
+(in-package #:quicklisp-client)
+
+(defun fetch-client-file-info (client-file-info output-file)
+  (maybe-fetch-gzipped (file-url client-file-info) output-file)
+  (check-client-file output-file client-file-info)
+  (probe-file output-file))
+
+(defun retirement-directory (base)
+  (let ((suffix 0))
+    (loop
+      (incf suffix)
+      (let* ((try (format nil "~A-~D" base suffix))
+             (dir (qmerge (make-pathname :directory
+                                         (list :relative "retired" try)))))
+        (unless (probe-directory dir)
+          (return dir))))))
+
+(defun retire (directory base)
+  (let ((retirement-home (qmerge "retired/"))
+        (from (truename directory)))
+    (ensure-directories-exist retirement-home)
+    (let* ((*default-pathname-defaults* retirement-home)
+           (to (retirement-directory base)))
+      (rename-directory from to)
+      to)))
+
+(defun client-update-scratch-directory (client-info)
+  (qmerge (make-pathname :directory
+                         (list :relative
+                               "tmp"
+                               "client-update"
+                               (version client-info)))))
+
+(defun %install-client (new-info local-info)
+  (let* ((work-directory (client-update-scratch-directory new-info))
+         (current-quicklisp-directory (qmerge "quicklisp/"))
+         (new-quicklisp-directory
+          (merge-pathnames "quicklisp/" work-directory))
+         (local-temp-tar (merge-pathnames "quicklisp.tar" work-directory))
+         (local-setup (merge-pathnames "setup.lisp" work-directory))
+         (local-asdf (merge-pathnames "asdf.lisp" work-directory))
+         (new-client-tar-p (not (info-equal (client-tar-info new-info)
+                                            (client-tar-info local-info))))
+         (new-setup-p (not (info-equal (setup-info new-info)
+                                       (setup-info local-info))))
+         (new-asdf-p (not (info-equal (asdf-info new-info)
+                                      (asdf-info local-info)))))
+    (ensure-directories-exist work-directory)
+    ;; Fetch and unpack quicklisp.tar if needed
+    (when new-client-tar-p
+      (fetch-client-file-info (client-tar-info new-info) local-temp-tar)
+      (unpack-tarball local-temp-tar :directory work-directory))
+    ;; Fetch setup.lisp if needed
+    (when new-setup-p
+      (fetch-client-file-info (setup-info new-info) local-setup))
+    ;; Fetch asdf.lisp if needed
+    (when new-asdf-p
+      (fetch-client-file-info (asdf-info new-info) local-asdf))
+    ;; Everything fetched, so move the old stuff away and move the new
+    ;; stuff in
+    (when new-client-tar-p
+      (retire (qmerge "quicklisp/")
+              (format nil "quicklisp-~A"
+                      (version local-info)))
+      (rename-directory new-quicklisp-directory current-quicklisp-directory))
+    (when new-setup-p
+      (replace-file local-setup (qmerge "setup.lisp")))
+    (when new-asdf-p
+      (replace-file local-asdf (qmerge "asdf.lisp")))
+    ;; But unconditionally move the new client-info into place
+    (replace-file (source-file new-info) (qmerge "client-info.sexp"))
+    new-info))
+
+(defun update-client (&key (prompt t))
+  (let* ((local-info (local-client-info))
+         (newest-info (newest-client-info local-info)))
+    (cond ((null newest-info)
+           (format t "No client update available.~%"))
+          ((client-version-lessp local-info newest-info)
+           (format t "Updating client from version ~A to version ~A.~%"
+                   (version local-info)
+                   (version newest-info))
+           (when (or (not prompt)
+                     (press-enter-to-continue))
+             (%install-client newest-info local-info)
+             (format t "~&New Quicklisp client installed. ~
+                          It will take effect on restart.~%")))
+          (t
+           (format t "The most up-to-date client, version ~A, ~
+                      is already installed.~%"
+                   (version local-info)))))
+  t)
+
+
+(defun install-client (&key url version)
+  (unless (or url version)
+    (error "One of ~S or ~S is required" :url :version))
+  (when (and url version)
+    (error "Only one of ~S or ~S is allowed" :url :version))
+  (when version
+    (setf url (client-info-url-from-version version)))
+  (let ((local-info (local-client-info))
+        (new-info (fetch-client-info url)))
+    (%install-client new-info local-info)))

sbcl/.quicklisp/quicklisp/client.lisp

@@ -0,0 +1,131 @@
+;;;; client.lisp
+
+(in-package #:quicklisp-client)
+
+(defvar *quickload-verbose* nil
+  "When NIL, show terse output when quickloading a system. Otherwise,
+  show normal compile and load output.")
+
+(defvar *quickload-prompt* nil
+  "When NIL, quickload systems without prompting for enter to
+  continue, otherwise proceed directly without user intervention.")
+
+(defvar *quickload-explain* t)
+
+(define-condition system-not-quickloadable (error)
+  ((system
+    :initarg :system
+    :reader not-quickloadable-system)))
+
+(defun maybe-silence (silent stream)
+  (or (and silent (make-broadcast-stream)) stream))
+
+(defgeneric quickload (systems &key verbose silent prompt explain &allow-other-keys)
+  (:documentation
+   "Load SYSTEMS the quicklisp way. SYSTEMS is a designator for a list
+   of things to be loaded.")
+  (:method (systems &key
+            (prompt *quickload-prompt*)
+            (silent nil)
+            (verbose *quickload-verbose*) &allow-other-keys)
+    (let ((*standard-output* (maybe-silence silent *standard-output*))
+          (*trace-output*    (maybe-silence silent *trace-output*)))
+      (unless (listp systems)
+        (setf systems (list systems)))
+      (dolist (thing systems systems)
+        (flet ((ql ()
+                 (autoload-system-and-dependencies thing :prompt prompt)))
+          (if verbose
+              (ql)
+              (call-with-quiet-compilation #'ql)))))))
+
+(defmethod quickload :around (systems &key verbose prompt explain
+                                      &allow-other-keys)
+  (declare (ignorable systems verbose prompt explain))
+  (with-consistent-dists
+    (call-next-method)))
+
+(defun system-list ()
+  (provided-systems t))
+
+(defun update-dist (dist &key (prompt t))
+  (when (stringp dist)
+    (setf dist (find-dist dist)))
+  (let ((new (available-update dist)))
+    (cond (new
+           (show-update-report dist new)
+           (when (or (not prompt) (press-enter-to-continue))
+             (update-in-place dist new)))
+          ((not (subscribedp dist))
+           (format t "~&You are not subscribed to ~S."
+                   (name dist)))
+          (t
+           (format t "~&You already have the latest version of ~S: ~A.~%"
+                   (name dist)
+                   (version dist))))))
+
+(defun update-all-dists (&key (prompt t))
+  (let ((dists (remove-if-not 'subscribedp (all-dists))))
+    (format t "~&~D dist~:P to check.~%" (length dists))
+    (dolist (old dists)
+      (with-simple-restart (skip "Skip update of dist ~S" (name old))
+        (update-dist old :prompt prompt)))))
+
+(defun available-dist-versions (name)
+  (available-versions (find-dist-or-lose name)))
+
+(defun help ()
+  "For help with Quicklisp, see http://www.quicklisp.org/beta/")
+
+(defun uninstall (system-name)
+  (let ((system (find-system system-name)))
+    (cond (system
+           (ql-dist:uninstall system))
+          (t
+           (warn "Unknown system ~S" system-name)
+           nil))))
+
+(defun uninstall-dist (name)
+  (let ((dist (find-dist name)))
+    (when dist
+      (ql-dist:uninstall dist))))
+
+(defun write-asdf-manifest-file (output-file &key (if-exists :rename-and-delete)
+                                               exclude-local-projects)
+  "Write a list of system file pathnames to OUTPUT-FILE, one per line,
+in order of descending QL-DIST:PREFERENCE."
+  (when (or (eql output-file nil)
+            (eql output-file t))
+    (setf output-file (qmerge "manifest.txt")))
+  (with-open-file (stream output-file
+                          :direction :output
+                          :if-exists if-exists)
+    (unless exclude-local-projects
+      (register-local-projects)
+      (dolist (system-file (list-local-projects))
+        (let* ((enough (enough-namestring system-file output-file))
+               (native (native-namestring enough)))
+          (write-line native stream))))
+    (with-consistent-dists
+      (let ((systems (provided-systems t))
+            (already-seen (make-hash-table :test 'equal)))
+        (dolist (system (sort systems #'>
+                              :key #'preference))
+          ;; FIXME: find-asdf-system-file does another find-system
+          ;; behind the scenes. Bogus. Should be a better way to go
+          ;; from system object to system file.
+          (let* ((system-file (find-asdf-system-file (name system)))
+                 (enough (and system-file (enough-namestring system-file
+                                                             output-file)))
+                 (native (and enough (native-namestring enough))))
+            (when (and native (not (gethash native already-seen)))
+              (setf (gethash native already-seen) native)
+              (format stream "~A~%" native)))))))
+  (probe-file output-file))
+
+(defun where-is-system (name)
+  "Return the pathname to the source directory of ASDF system with the
+given NAME, or NIL if no system by that name can be found known."
+  (let ((system (asdf:find-system name nil)))
+    (when system
+      (asdf:system-source-directory system))))

sbcl/.quicklisp/quicklisp/config.lisp

@@ -0,0 +1,40 @@
+;;;; config.lisp
+
+(in-package #:ql-config)
+
+(defun config-value-file-pathname (path)
+  (let ((bad-position (position #\Space path)))
+    (when bad-position
+      (error "Space not allowed at position ~D in ~S"
+             bad-position
+             path)))
+  (let* ((space-path (substitute #\Space #\/ path))
+         (split (split-spaces space-path))
+         (directory-parts (butlast split))
+         (name (first (last split)))
+         (base (qmerge "config/")))
+     (merge-pathnames
+      (make-pathname :name name
+                     :type "txt"
+                     :directory (list* :relative directory-parts))
+      base)))
+
+(defun config-value (path)
+  (let ((file (config-value-file-pathname path)))
+    (with-open-file (stream file :if-does-not-exist nil)
+      (when stream
+        (values (read-line stream nil))))))
+
+(defun (setf config-value) (new-value path)
+  (let ((file (config-value-file-pathname path)))
+    (typecase new-value
+      (null
+       (delete-file-if-exists file))
+      (string
+       (ensure-directories-exist file)
+       (with-open-file (stream file :direction :output
+                               :if-does-not-exist :create
+                               :if-exists :rename-and-delete)
+         (write-line new-value stream)))
+      (t
+       (error "Bad config value ~S; must be a string or NIL" new-value)))))

sbcl/.quicklisp/quicklisp/deflate.lisp

@@ -0,0 +1,785 @@
+;;;; Deflate --- RFC 1951 Deflate Decompression
+;;;;
+;;;; Copyright (C) 2000-2009 PMSF IT Consulting Pierre R. Mai.
+;;;;
+;;;; Permission is hereby granted, free of charge, to any person obtaining
+;;;; a copy of this software and associated documentation files (the
+;;;; "Software"), to deal in the Software without restriction, including
+;;;; without limitation the rights to use, copy, modify, merge, publish,
+;;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;;; permit persons to whom the Software is furnished to do so, subject to
+;;;; the following conditions:
+;;;;
+;;;; The above copyright notice and this permission notice shall be
+;;;; included in all copies or substantial portions of the Software.
+;;;;
+;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR
+;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
+;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;;; OTHER DEALINGS IN THE SOFTWARE.
+;;;;
+;;;; Except as contained in this notice, the name of the author shall
+;;;; not be used in advertising or otherwise to promote the sale, use or
+;;;; other dealings in this Software without prior written authorization
+;;;; from the author.
+;;;; 
+;;;; $Id: 377d3a33e9db5a3b54c850619183ee555a41b894 $
+
+(cl:in-package #:ql-gunzipper)
+
+;;;; %File Description:
+;;;; 
+;;;; This file contains routines implementing the RFC 1951 Deflate
+;;;; Compression and/or Decompression method, as used by e.g. gzip and
+;;;; other compression and archiving tools and protocols.  It also
+;;;; implements handling routines for zlib-style (RFC 1950) and
+;;;; gzip-style (RFC 1952) wrappers around raw Deflate streams.
+;;;; 
+;;;; The main entry points are the functions inflate-stream, and its
+;;;; cousins inflate-zlib-stream and inflate-gzip-stream, which take
+;;;; an input-stream and an output-stream as their arguments, and
+;;;; inflate the RFC 1951, RFC 1950 or RFC 1952-style deflate formats
+;;;; from the input-stream to the output-stream.
+;;;;
+
+;;;
+;;; Conditions
+;;;
+
+(define-condition decompression-error (simple-error)
+  ())
+
+(define-condition deflate-decompression-error (decompression-error)
+  ()
+  (:report 
+   (lambda (c s)
+     (with-standard-io-syntax
+       (let ((*print-readably* nil))
+         (format s 
+                 "Error detected during deflate decompression: ~?"
+                 (simple-condition-format-control c)
+                 (simple-condition-format-arguments c)))))))
+
+(define-condition zlib-decompression-error (decompression-error)
+  ()
+  (:report 
+   (lambda (c s)
+     (with-standard-io-syntax
+       (let ((*print-readably* nil))
+         (format s 
+                 "Error detected during zlib decompression: ~?"
+                 (simple-condition-format-control c)
+                 (simple-condition-format-arguments c)))))))
+
+(define-condition gzip-decompression-error (decompression-error)
+  ()
+  (:report 
+   (lambda (c s)
+     (with-standard-io-syntax
+       (let ((*print-readably* nil))
+         (format s 
+                 "Error detected during zlib decompression: ~?"
+                 (simple-condition-format-control c)
+                 (simple-condition-format-arguments c)))))))
+
+;;;
+;;; Adler-32 Checksums
+;;;
+
+(defconstant +adler-32-start-value+ 1
+  "Start value for Adler-32 checksums as per RFC 1950.")
+
+(defconstant +adler-32-base+ 65521
+  "Base value for Adler-32 checksums as per RFC 1950.")
+
+(declaim (ftype 
+          (function ((unsigned-byte 32) (simple-array (unsigned-byte 8) (*)) fixnum)
+                    (unsigned-byte 32))
+          update-adler32-checksum))
+(defun update-adler32-checksum (crc buffer end)
+  (declare (type (unsigned-byte 32) crc)
+           (type (simple-array (unsigned-byte 8) (*)) buffer)
+           (type fixnum end)
+           (optimize (speed 3) (debug 0) (space 0) (safety 0))
+           #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
+  (let ((s1 (ldb (byte 16 0) crc))
+        (s2 (ldb (byte 16 16) crc)))
+    (declare (type (unsigned-byte 32) s1 s2))
+    (dotimes (i end)
+      (declare (type fixnum i))
+      (setq s1 (mod (+ s1 (aref buffer i)) +adler-32-base+)
+            s2 (mod (+ s2 s1) +adler-32-base+)))
+    (dpb s2 (byte 16 16) s1)))
+
+;;;
+;;; CRC-32 Checksums
+;;;
+
+(defconstant +crc-32-start-value+ 0
+  "Start value for CRC-32 checksums as per RFC 1952.")
+
+(defconstant +crc-32-polynomial+ #xedb88320
+  "CRC-32 Polynomial as per RFC 1952.")
+
+(declaim (ftype #-lispworks (function () (simple-array (unsigned-byte 32) (256)))
+                #+lispworks (function () (sys:simple-int32-vector 256))
+                generate-crc32-table))
+(defun generate-crc32-table ()
+  (let ((result #-lispworks (make-array 256 :element-type '(unsigned-byte 32))
+                #+lispworks (sys:make-simple-int32-vector 256)))
+    (dotimes (i #-lispworks (length result) #+lispworks 256 result)
+      (let ((cur i))
+        (dotimes (k 8)
+          (setq cur (if (= 1 (logand cur 1))
+                        (logxor (ash cur -1) +crc-32-polynomial+)
+                        (ash cur -1))))
+        #-lispworks (setf (aref result i) cur)
+        #+lispworks (setf (sys:int32-aref result i)
+                          (sys:integer-to-int32
+                           (dpb (ldb (byte 32 0) cur) (byte 32 0) 
+                                (if (logbitp 31 cur) -1 0))))))))
+
+(declaim (ftype 
+          (function ((unsigned-byte 32) (simple-array (unsigned-byte 8) (*)) fixnum)
+                    (unsigned-byte 32))
+          update-crc32-checksum))
+#-lispworks
+(defun update-crc32-checksum (crc buffer end)
+  (declare (type (unsigned-byte 32) crc)
+           (type (simple-array (unsigned-byte 8) (*)) buffer)
+           (type fixnum end)
+           (optimize (speed 3) (debug 0) (space 0) (safety 0))
+           #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
+  (let ((table (load-time-value (generate-crc32-table)))
+        (cur (logxor crc #xffffffff)))
+    (declare (type (simple-array (unsigned-byte 32) (256)) table)
+             (type (unsigned-byte 32) cur))
+    (dotimes (i end)
+      (declare (type fixnum i))
+      (let ((index (logand #xff (logxor cur (aref buffer i)))))
+        (declare (type (unsigned-byte 8) index))
+        (setq cur (logxor (aref table index) (ash cur -8)))))
+    (logxor cur #xffffffff)))
+
+#+lispworks
+(defun update-crc32-checksum (crc buffer end)
+  (declare (type (unsigned-byte 32) crc)
+           (type (simple-array (unsigned-byte 8) (*)) buffer)
+           (type fixnum end)
+           (optimize (speed 3) (debug 0) (space 0) (safety 0) (float 0)))
+  (let ((table (load-time-value (generate-crc32-table)))
+        (cur (sys:int32-lognot (sys:integer-to-int32 
+                                (dpb (ldb (byte 32 0) crc) (byte 32 0) 
+                                     (if (logbitp 31 crc) -1 0))))))
+    (declare (type (sys:simple-int32-vector 256) table)
+             (type sys:int32 cur))
+    (dotimes (i end)
+      (declare (type fixnum i))
+      (let ((index (sys:int32-to-integer
+                    (sys:int32-logand #xff (sys:int32-logxor cur (aref buffer i))))))
+        (declare (type fixnum index))
+        (setq cur (sys:int32-logxor (sys:int32-aref table index)
+                                    (sys:int32-logand #x00ffffff 
+                                                      (sys:int32>> cur 8))))))
+    (ldb (byte 32 0) (sys:int32-to-integer (sys:int32-lognot cur)))))
+
+;;;
+;;; Helper Data Structures: Sliding Window Stream
+;;;
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant +sliding-window-size+ 32768
+    "Size of sliding window for RFC 1951 Deflate compression scheme."))
+
+(defstruct sliding-window-stream
+  (stream nil :type stream :read-only t)
+  (buffer (make-array +sliding-window-size+ :element-type '(unsigned-byte 8)) 
+   :type (simple-array (unsigned-byte 8) (#.+sliding-window-size+)) :read-only t)
+  (buffer-end 0 :type fixnum)
+  (checksum nil :type symbol :read-only t)
+  (checksum-value 0 :type (unsigned-byte 32)))
+
+(declaim (inline sliding-window-stream-write-byte))
+(defun sliding-window-stream-write-byte (stream byte)
+  (declare (type sliding-window-stream stream) (type (unsigned-byte 8) byte)
+           #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
+  "Write a single byte to the sliding-window-stream."
+  (let ((end (sliding-window-stream-buffer-end stream)))
+    (declare (type fixnum end))
+    (unless (< end +sliding-window-size+)
+      (write-sequence (sliding-window-stream-buffer stream)
+                      (sliding-window-stream-stream stream))
+      (case (sliding-window-stream-checksum stream)
+        (:adler-32 (setf (sliding-window-stream-checksum-value stream)
+                         (update-adler32-checksum
+                          (sliding-window-stream-checksum-value stream)
+                          (sliding-window-stream-buffer stream)
+                          +sliding-window-size+)))
+        (:crc-32 (setf (sliding-window-stream-checksum-value stream)
+                       (update-crc32-checksum
+                        (sliding-window-stream-checksum-value stream)
+                        (sliding-window-stream-buffer stream)
+                        +sliding-window-size+))))
+      (setq end 0))
+    (setf (aref (sliding-window-stream-buffer stream) end) byte
+          (sliding-window-stream-buffer-end stream) (1+ end))))
+
+(defun sliding-window-stream-flush (stream)
+  (declare (type sliding-window-stream stream))
+  "Flush any remaining buffered bytes from the stream."
+  (let ((end (sliding-window-stream-buffer-end stream)))
+    (declare (type fixnum end))
+    (unless (zerop end)
+      (case (sliding-window-stream-checksum stream)
+        (:adler-32 (setf (sliding-window-stream-checksum-value stream)
+                         (update-adler32-checksum
+                          (sliding-window-stream-checksum-value stream)
+                          (sliding-window-stream-buffer stream)
+                          end)))
+        (:crc-32 (setf (sliding-window-stream-checksum-value stream)
+                       (update-crc32-checksum
+                        (sliding-window-stream-checksum-value stream)
+                        (sliding-window-stream-buffer stream)
+                        end))))
+      (write-sequence (sliding-window-stream-buffer stream)
+                      (sliding-window-stream-stream stream)
+                      :end end))))
+
+(defun sliding-window-stream-copy-bytes (stream distance length)
+  (declare (type sliding-window-stream stream) (type fixnum distance length))
+  "Copy a number of bytes from the current sliding window."
+  (let* ((end (sliding-window-stream-buffer-end stream))
+         (start (mod (- end distance) +sliding-window-size+))
+         (buffer (sliding-window-stream-buffer stream)))
+    (declare (type fixnum end start)
+             (type (simple-array (unsigned-byte 8) (#.+sliding-window-size+)) buffer))
+    (dotimes (i length)
+      (sliding-window-stream-write-byte
+       stream
+       (aref buffer (mod (+ start i) +sliding-window-size+))))))
+
+;;;
+;;; Helper Data Structures: Bit-wise Input Stream
+;;;
+
+(defstruct bit-stream
+  (stream nil :type stream :read-only t)
+  (next-byte 0 :type fixnum)
+  (bits 0 :type (unsigned-byte 29))
+  (bit-count 0 :type (unsigned-byte 8)))
+
+(declaim (inline bit-stream-get-byte))
+(defun bit-stream-get-byte (stream)
+  (declare (type bit-stream stream))
+  "Read another byte from the underlying stream."
+  (the (unsigned-byte 8) (read-byte (bit-stream-stream stream))))
+
+(declaim (inline bit-stream-read-bits))
+(defun bit-stream-read-bits (stream bits)
+  (declare (type bit-stream stream)
+           ;; [quicklisp-added]
+           ;; FIXME: This might be fixed soon in ECL.
+           ;; http://article.gmane.org/gmane.lisp.ecl.general/7659
+           #-ecl
+           (type (unsigned-byte 8) bits))
+  "Read single or multiple bits from the given bit-stream."
+  (loop while (< (bit-stream-bit-count stream) bits)
+        do
+     ;; Fill bits
+     (setf (bit-stream-bits stream)
+           (logior (bit-stream-bits stream)
+                   (the (unsigned-byte 29)
+                     (ash (bit-stream-get-byte stream)
+                          (bit-stream-bit-count stream))))
+           (bit-stream-bit-count stream) (+ (bit-stream-bit-count stream) 8)))
+  ;; Return properly masked bits
+  (if (= (bit-stream-bit-count stream) bits)
+      (prog1 (bit-stream-bits stream)
+        (setf (bit-stream-bits stream) 0
+              (bit-stream-bit-count stream) 0))
+      (prog1 (ldb (byte bits 0) (bit-stream-bits stream))
+        (setf (bit-stream-bits stream) (ash (bit-stream-bits stream) (- bits))
+              (bit-stream-bit-count stream) (- (bit-stream-bit-count stream) bits)))))
+
+(declaim (inline bit-stream-copy-block))
+(defun bit-stream-copy-block (stream out-stream)
+  (declare (type bit-stream stream) (type sliding-window-stream out-stream)
+           (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+  "Copy a given block of bytes directly from the underlying stream."
+  ;; Skip any remaining unprocessed bits
+  (setf (bit-stream-bits stream) 0
+        (bit-stream-bit-count stream) 0)
+  ;; Get LEN/NLEN and copy bytes
+  (let* ((len (logior (bit-stream-get-byte stream)
+                      (ash (bit-stream-get-byte stream) 8)))
+         (nlen (ldb (byte 16 0) 
+                    (lognot (logior (bit-stream-get-byte stream)
+                                    (ash (bit-stream-get-byte stream) 8))))))
+    (unless (= len nlen)
+      (error 'deflate-decompression-error
+             :format-control 
+             "Block length mismatch for stored block: LEN(~D) vs. NLEN(~D)!"
+             :format-arguments (list len nlen)))
+    (dotimes (i len)
+      (sliding-window-stream-write-byte out-stream (bit-stream-get-byte stream)))))
+
+;;;
+;;; Huffman Coding
+;;;
+
+;;; A decode-tree struct contains all information necessary to decode
+;;; the given canonical huffman code.  Note that length-count contains
+;;; the number of codes with a given length for each length, whereas
+;;; the code-symbols array contains the symbols corresponding to the
+;;; codes in canoical order of the codes.
+;;;
+;;; Decoding then uses this information and the principles underlying
+;;; canonical huffman codes to determine whether the currently
+;;; collected word falls between the first code and the last code for
+;;; the current length, and if so, uses the offset to determine the
+;;; code's symbol.  Otherwise more bits are needed.
+
+(defstruct decode-tree
+  (length-count (make-array 16 :element-type 'fixnum :initial-element 0)
+   :type (simple-array fixnum (*)) :read-only t)
+  (code-symbols (make-array 16 :element-type 'fixnum :initial-element 0)
+   :type (simple-array fixnum (*))))
+
+(defun make-huffman-decode-tree (code-lengths)
+  "Construct a huffman decode-tree for the canonical huffman code with
+the code lengths of each symbol given in the input array."
+  (let* ((max-length (reduce #'max code-lengths :initial-value 0))
+         (next-code (make-array (1+ max-length) :element-type 'fixnum
+                                :initial-element 0))
+         (code-symbols (make-array (length code-lengths) :element-type 'fixnum
+                                   :initial-element 0))
+         (length-count (make-array (1+ max-length) :element-type 'fixnum
+                                   :initial-element 0)))
+    ;; Count length occurences and calculate offsets of smallest codes
+    (loop for index from 1 to max-length
+          for code = 0 then (+ code (aref length-count (1- index)))
+          do
+       (setf (aref next-code index) code)
+          initially
+       ;; Count length occurences
+       (loop for length across code-lengths
+             do
+          (incf (aref length-count length))
+             finally
+          (setf (aref length-count 0) 0)))
+    ;; Construct code symbols mapping
+    (loop for length across code-lengths
+          for index upfrom 0
+          unless (zerop length)
+            do
+         (setf (aref code-symbols (aref next-code length)) index)
+         (incf (aref next-code length)))
+    ;; Return result
+    (make-decode-tree :length-count length-count :code-symbols code-symbols)))
+
+(declaim (inline read-huffman-code))
+(defun read-huffman-code (bit-stream decode-tree)
+  (declare (type bit-stream bit-stream) (type decode-tree decode-tree)
+           (optimize (speed 3) (safety 0) (space 0) (debug 0)))
+  "Read the next huffman code word from the given bit-stream and
+return its decoded symbol, for the huffman code given by decode-tree."
+  (loop with length-count of-type (simple-array fixnum (*)) 
+          = (decode-tree-length-count decode-tree)
+        with code-symbols of-type (simple-array fixnum (*))
+          = (decode-tree-code-symbols decode-tree)
+        for code of-type fixnum = (bit-stream-read-bits bit-stream 1)
+          then (+ (* code 2) (bit-stream-read-bits bit-stream 1))
+        for index of-type fixnum = 0 then (+ index count)
+        for first of-type fixnum = 0 then (* (+ first count) 2)
+        for length of-type fixnum upfrom 1 below (length length-count)
+        for count = (aref length-count length)
+        thereis (when (< code (the fixnum (+ first count)))
+                  (aref code-symbols (+ index (- code first))))
+        finally
+     (error 'deflate-decompression-error
+            :format-control 
+            "Corrupted Data detected during decompression: ~
+             Incorrect huffman code (~X) in huffman decode!"
+            :format-arguments (list code))))
+
+;;;
+;;; Standard Huffman Tables
+;;;
+
+(defparameter *std-lit-decode-tree* 
+  (make-huffman-decode-tree 
+   (concatenate 'vector
+                (make-sequence 'vector 144 :initial-element 8)
+                (make-sequence 'vector 112 :initial-element 9)
+                (make-sequence 'vector 24 :initial-element 7)
+                (make-sequence 'vector 8 :initial-element 8))))
+                
+(defparameter *std-dist-decode-tree* 
+  (make-huffman-decode-tree
+   (make-sequence 'vector 32 :initial-element 5)))
+
+;;;
+;;; Dynamic Huffman Table Handling
+;;;
+
+(defparameter *code-length-entry-order*
+  #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15)
+  "Order of Code Length Tree Code Lengths.")
+
+(defun decode-code-length-entries (bit-stream count decode-tree)
+  "Decode the given number of code length entries from the bit-stream 
+using the given decode-tree, and return a corresponding array of code 
+lengths for further processing."
+  (do ((result (make-array count :element-type 'fixnum :initial-element 0))
+       (index 0))
+      ((>= index count) result)
+    (let ((code (read-huffman-code bit-stream decode-tree)))
+      (ecase code
+        ((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+           (setf (aref result index) code)
+           (incf index))
+        (16
+           (let ((length (+ 3 (bit-stream-read-bits bit-stream 2))))
+             (dotimes (i length)
+               (setf (aref result (+ index i)) (aref result (1- index))))
+             (incf index length)))
+        (17
+           (let ((length (+ 3 (bit-stream-read-bits bit-stream 3))))
+             (dotimes (i length)
+               (setf (aref result (+ index i)) 0))
+             (incf index length)))
+        (18
+           (let ((length (+ 11 (bit-stream-read-bits bit-stream 7))))
+             (dotimes (i length)
+               (setf (aref result (+ index i)) 0))
+             (incf index length)))))))
+
+(defun decode-huffman-tables (bit-stream)
+  "Decode the stored huffman tables from the given bit-stream, returning
+the corresponding decode-trees for literals/length and distance codes."
+  (let* ((hlit (bit-stream-read-bits bit-stream 5))
+         (hdist (bit-stream-read-bits bit-stream 5))
+         (hclen (bit-stream-read-bits bit-stream 4)))
+    ;; Construct Code Length Decode Tree
+    (let ((cl-decode-tree
+           (loop with code-lengths = (make-array 19 :element-type '(unsigned-byte 8) 
+                                          :initial-element 0)
+                 for index from 0 below (+ hclen 4)
+                 for code-length = (bit-stream-read-bits bit-stream 3)
+                 for code-index = (aref *code-length-entry-order* index)
+                 do
+              (setf (aref code-lengths code-index) code-length)
+                 finally
+              (return (make-huffman-decode-tree code-lengths)))))
+      ;; Decode Code Length Table and generate separate huffman trees
+      (let ((entries (decode-code-length-entries bit-stream 
+                                                 (+ hlit 257 hdist 1)
+                                                 cl-decode-tree)))
+        (values 
+          (make-huffman-decode-tree (subseq entries 0 (+ hlit 257)))
+          (make-huffman-decode-tree (subseq entries (+ hlit 257))))))))
+
+;;;
+;;; Compressed Block Handling
+;;;
+
+(declaim (inline decode-length-entry))
+(defun decode-length-entry (symbol bit-stream)
+  "Decode the given length symbol into a proper length specification."
+  (cond
+    ((<= symbol 264) (- symbol 254))
+    ((<= symbol 268) (+ 11 (* (- symbol 265) 2) (bit-stream-read-bits bit-stream 1)))
+    ((<= symbol 272) (+ 19 (* (- symbol 269) 4) (bit-stream-read-bits bit-stream 2)))
+    ((<= symbol 276) (+ 35 (* (- symbol 273) 8) (bit-stream-read-bits bit-stream 3)))
+    ((<= symbol 280) (+ 67 (* (- symbol 277) 16) (bit-stream-read-bits bit-stream 4)))
+    ((<= symbol 284)
+     (+ 131 (* (- symbol 281) 32) (bit-stream-read-bits bit-stream 5)))
+    ((= symbol 285) 258)
+    (t 
+     (error 'deflate-decompression-error 
+            :format-control "Strange Length Code in bitstream: ~D" 
+            :format-arguments (list symbol)))))
+
+(declaim (inline decode-distance-entry))
+(defun decode-distance-entry (symbol bit-stream)
+  "Decode the given distance symbol into a proper distance specification."
+  (cond
+    ((<= symbol 3) (1+ symbol))
+    (t
+     (multiple-value-bind (order offset) (truncate symbol 2)
+       (let* ((extra-bits (1- order))
+              (factor (ash 1 extra-bits)))
+         (+ (1+ (ash 1 order))
+            (* offset factor)
+            (bit-stream-read-bits bit-stream extra-bits)))))))
+
+(defun decode-huffman-block (bit-stream window-stream 
+                             lit-decode-tree dist-decode-tree)
+  "Decode the huffman code block using the huffman codes given by 
+lit-decode-tree and dist-decode-tree."
+  (do ((symbol (read-huffman-code bit-stream lit-decode-tree)
+               (read-huffman-code bit-stream lit-decode-tree)))
+      ((= symbol 256))
+    (cond
+      ((<= symbol 255)
+       (sliding-window-stream-write-byte window-stream symbol))
+      (t
+       (let ((length (decode-length-entry symbol bit-stream))
+             (distance (decode-distance-entry 
+                        (read-huffman-code bit-stream dist-decode-tree) bit-stream)))
+         (sliding-window-stream-copy-bytes window-stream distance length))))))
+
+;;;
+;;; Block Handling Code
+;;;
+
+(defun decode-block (bit-stream window-stream)
+  "Decompress a block read from bit-stream into window-stream."
+  (let* ((finalp (not (zerop (bit-stream-read-bits bit-stream 1))))
+         (type (bit-stream-read-bits bit-stream 2)))
+    (ecase type
+      (#b00 (bit-stream-copy-block bit-stream window-stream))
+      (#b01 
+         (decode-huffman-block bit-stream window-stream 
+                               *std-lit-decode-tree* 
+                               *std-dist-decode-tree*))
+      (#b10 
+         (multiple-value-bind (lit-decode-tree dist-decode-tree)
+             (decode-huffman-tables bit-stream)
+           (decode-huffman-block bit-stream window-stream 
+                                 lit-decode-tree dist-decode-tree)))
+      (#b11 
+         (error 'deflate-decompression-error 
+                :format-control "Encountered Reserved Block Type ~D!"
+                :format-arguments (list type))))
+    (not finalp)))
+
+;;;
+;;; ZLIB - RFC 1950 handling
+;;;
+
+(defun parse-zlib-header (input-stream)
+  "Parse a ZLIB-style header as per RFC 1950 from the input-stream and
+return the compression-method, compression-level dictionary-id and flags
+fields of the header as return values.  Checks the header for corruption
+and signals a zlib-decompression-error in case of corruption."
+  (let ((compression-method (read-byte input-stream))
+        (flags (read-byte input-stream)))
+    (unless (zerop (mod (+ (* compression-method 256) flags) 31))
+      (error 'zlib-decompression-error
+             :format-control "Corrupted Header ~2,'0X,~2,'0X!"
+             :format-arguments (list compression-method flags)))
+    (let ((dict (unless (zerop (ldb (byte 1 5) flags))
+                  (parse-zlib-checksum input-stream))))
+      (values (ldb (byte 4 0) compression-method)
+              (ldb (byte 4 4) compression-method)
+              dict
+              (ldb (byte 2 6) flags)))))
+
+(defun parse-zlib-checksum (input-stream)
+  (+ (* (read-byte input-stream) 256 256 256)
+     (* (read-byte input-stream) 256 256)
+     (* (read-byte input-stream) 256)
+     (read-byte input-stream)))
+
+(defun parse-zlib-footer (input-stream)
+  "Parse the ZLIB-style footer as per RFC 1950 from the input-stream and
+return the Adler-32 checksum contained in the footer as its return value."
+  (parse-zlib-checksum input-stream))
+
+;;;
+;;; GZIP - RFC 1952 handling
+;;;
+
+(defconstant +gzip-header-id1+ 31
+  "GZIP Header Magic Value ID1 as per RFC 1952.")
+
+(defconstant +gzip-header-id2+ 139
+  "GZIP Header Magic Value ID2 as per RFC 1952.")
+
+(defun parse-gzip-header (input-stream)
+  "Parse a GZIP-style header as per RFC 1952 from the input-stream and
+return the compression-method, text-flag, modification time, XFLAGS,
+OS, FEXTRA flags, filename, comment and CRC16 fields of the header as
+return values (or nil if any given field is not present).  Checks the
+header for magic values and correct flags settings and signals a
+gzip-decompression-error in case of incorrect or unsupported magic
+values or flags."
+  (let ((id1 (read-byte input-stream))
+        (id2 (read-byte input-stream))
+        (compression-method (read-byte input-stream))
+        (flags (read-byte input-stream)))
+    (unless (and (= id1 +gzip-header-id1+) (= id2 +gzip-header-id2+))
+      (error 'gzip-decompression-error
+             :format-control
+             "Header missing magic values ~2,'0X,~2,'0X (got ~2,'0X,~2,'0X instead)!"
+             :format-arguments (list +gzip-header-id1+ +gzip-header-id2+ id1 id2)))
+    (unless (= compression-method 8)
+      (error 'gzip-decompression-error
+             :format-control "Unknown compression-method in Header ~2,'0X!"
+             :format-arguments (list compression-method)))
+    (unless (zerop (ldb (byte 3 5) flags))
+      (error 'gzip-decompression-error
+             :format-control "Unknown flags in Header ~2,'0X!"
+             :format-arguments (list flags)))
+    (values compression-method
+            ;; FTEXT
+            (= 1 (ldb (byte 1 0) flags))
+            ;; MTIME
+            (parse-gzip-mtime input-stream)
+            ;; XFLAGS
+            (read-byte input-stream)
+            ;; OS
+            (read-byte input-stream)
+            ;; FEXTRA
+            (unless (zerop (ldb (byte 1 2) flags))
+              (parse-gzip-extra input-stream))
+            ;; FNAME
+            (unless (zerop (ldb (byte 1 3) flags))
+              (parse-gzip-string input-stream))
+            ;; FCOMMENT
+            (unless (zerop (ldb (byte 1 4) flags))
+              (parse-gzip-string input-stream))
+            ;; CRC16
+            (unless (zerop (ldb (byte 1 1) flags))
+              (+ (read-byte input-stream)
+                 (* (read-byte input-stream 256)))))))
+
+(defun parse-gzip-mtime (input-stream)
+  (let ((time (+ (read-byte input-stream)
+                 (* (read-byte input-stream) 256)
+                 (* (read-byte input-stream) 256 256)
+                 (* (read-byte input-stream) 256 256 256))))
+    (if (zerop time)
+        nil
+        (+ time 2208988800))))
+
+(defun parse-gzip-extra (input-stream)
+  (let* ((length (+ (read-byte input-stream) (* (read-byte input-stream) 256)))
+         (result (make-array length :element-type '(unsigned-byte 8))))
+    (read-sequence result input-stream)
+    result))
+
+(defun parse-gzip-string (input-stream)
+  (with-output-to-string (string)
+    (loop for value = (read-byte input-stream)
+          until (zerop value)
+          do (write-char (code-char value) string))))
+          
+(defun parse-gzip-checksum (input-stream)
+  (+ (read-byte input-stream)
+     (* (read-byte input-stream) 256)
+     (* (read-byte input-stream) 256 256)
+     (* (read-byte input-stream) 256 256 256)))
+
+(defun parse-gzip-footer (input-stream)
+  "Parse the GZIP-style footer as per RFC 1952 from the input-stream and
+return the CRC-32 checksum and ISIZE fields contained in the footer as
+its return values."
+  (values (parse-gzip-checksum input-stream)
+          ;; ISIZE
+          (+ (read-byte input-stream)
+             (* (read-byte input-stream) 256)
+             (* (read-byte input-stream) 256 256)
+             (* (read-byte input-stream) 256 256 256))))
+
+;;;
+;;; Main Entry Points
+;;;
+
+(defun inflate-stream (input-stream output-stream &key checksum)
+  "Inflate the RFC 1951 data from the given input stream into the
+given output stream, which are required to have an element-type
+of (unsigned-byte 8).  If checksum is given, it indicates the
+checksumming algorithm to employ in calculating a checksum of
+the expanded content, which is then returned from this function.
+Valid values are :adler-32 for Adler-32 checksum (see RFC 1950),
+or :crc-32 for CRC-32 as per ISO 3309 (see RFC 1952, ZIP)."
+  (loop with window-stream = (make-sliding-window-stream :stream output-stream
+                                  :checksum checksum
+                                  :checksum-value
+                                  (ecase checksum
+                                    ((nil) 0)
+                                    (:crc-32 +crc-32-start-value+)
+                                    (:adler-32 +adler-32-start-value+)))
+        with bit-stream = (make-bit-stream :stream input-stream)
+        while (decode-block bit-stream window-stream)
+        finally (sliding-window-stream-flush window-stream)
+                (when checksum 
+                  (return (sliding-window-stream-checksum-value window-stream)))))
+
+(defun inflate-zlib-stream (input-stream output-stream &key check-checksum)
+  "Inflate the RFC 1950 zlib data from the given input stream into
+the given output stream, which are required to have an element-type
+of (unsigned-byte 8).  This returns the Adler-32 checksum of the
+file as its first return value, with the compression level as its
+second return value.  Note that it is the responsibility of the 
+caller to check whether the expanded data matches the Adler-32
+checksum, unless the check-checksum keyword argument is set to
+true, in which case the checksum is checked internally and a
+zlib-decompression-error is signalled if they don't match."
+  (multiple-value-bind (cm cinfo dictid flevel) (parse-zlib-header input-stream)
+    (unless (= cm 8)
+      (error 'zlib-decompression-error
+             :format-control "Unknown compression method ~D!"
+             :format-arguments (list cm)))
+    (unless (<= cinfo 7)
+      (error 'zlib-decompression-error
+             :format-control "Unsupported sliding window size 2^~D = ~D!"
+             :format-arguments (list (+ 8 cinfo) (expt 2 (+ 8 cinfo)))))
+    (unless (null dictid)
+      (error 'zlib-decompression-error
+             :format-control "Unknown preset dictionary id ~8,'0X!"
+             :format-arguments (list dictid)))
+    (let ((checksum-new (inflate-stream input-stream output-stream 
+                                        :checksum (when check-checksum :adler-32)))
+          (checksum-old (parse-zlib-footer input-stream)))
+      (when (and check-checksum (not (= checksum-old checksum-new)))
+        (error 'zlib-decompression-error
+               :format-control
+               "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!"
+               :format-arguments (list checksum-old checksum-new)))
+      (values checksum-old flevel))))
+
+(defun inflate-gzip-stream (input-stream output-stream &key check-checksum)
+  "Inflate the RFC 1952 gzip data from the given input stream into
+the given output stream, which are required to have an element-type
+of (unsigned-byte 8).  This returns the CRC-32 checksum of the
+file as its first return value, with any filename, modification time,
+and comment fields as further return values or nil if not present.
+Note that it is the responsibility of the caller to check whether the
+expanded data matches the CRC-32 checksum, unless the check-checksum
+keyword argument is set to true, in which case the checksum is checked
+internally and a gzip-decompression-error is signalled if they don't
+match."
+  (multiple-value-bind (cm ftext mtime xfl os fextra fname fcomment)
+      (parse-gzip-header input-stream)
+    (declare (ignore ftext xfl os fextra))
+    (unless (= cm 8)
+      (error 'gzip-decompression-error
+             :format-control "Unknown compression method ~D!"
+             :format-arguments (list cm)))
+    (let ((checksum-new (inflate-stream input-stream output-stream 
+                                        :checksum (when check-checksum :crc-32)))
+          (checksum-old (parse-gzip-footer input-stream)))
+      ;; Handle Checksums
+      (when (and check-checksum (not (= checksum-old checksum-new)))
+        (error 'gzip-decompression-error
+               :format-control
+               "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!"
+               :format-arguments (list checksum-old checksum-new)))
+      (values checksum-old fname mtime fcomment))))
+
+
+(defun gunzip (input-file output-file)
+  (with-open-file (input input-file
+                         :element-type '(unsigned-byte 8))
+    (with-open-file (output output-file
+                            :direction :output
+                            :if-exists :supersede
+                            :element-type '(unsigned-byte 8))
+      (inflate-gzip-stream input output)))
+  (probe-file output-file))

sbcl/.quicklisp/quicklisp/dist-update.lisp

@@ -0,0 +1,164 @@
+;;;; dist-update.lisp
+
+(in-package #:ql-dist)
+
+(defgeneric available-update (dist)
+  (:documentation "If an update is available for DIST, return the
+  update as an uninstalled dist object. Otherwise, return NIL."))
+
+(defgeneric update-release-differences (old-dist new-dist)
+  (:documentation "Compare OLD-DIST to NEW-DIST and return three lists
+  as multiple values: new releases \(present in NEW-DIST but not
+  OLD-DIST), changed releases \(present in both dists but different in
+  some way), and removed releases \(present in OLD-DIST but not
+  NEW-DIST). The list of changed releases is a list of two-element
+  lists, with each two-element list having first the old release
+  object and then the new release object."))
+
+(defgeneric show-update-report (old-dist new-dist)
+  (:documentation "Display a description of the update from OLD-DIST
+  to NEW-DIST."))
+
+(defgeneric update-in-place (old-dist new-dist)
+  (:documentation "Update OLD-DIST to NEW-DIST in place."))
+
+(defmethod available-update ((dist dist))
+  (let ((url (distinfo-subscription-url dist))
+        (target (qmerge "tmp/distinfo-update/distinfo.txt"))
+        (update-directory (qmerge "tmp/distinfo-update/")))
+    (when (probe-directory update-directory)
+      (delete-directory-tree (qmerge "tmp/distinfo-update/")))
+    (when url
+      (ensure-directories-exist target)
+      (fetch url target :quietly t)
+      (let ((new (make-dist-from-file target)))
+        (setf (base-directory new)
+              (make-pathname :name nil
+                             :type nil
+                             :version nil
+                             :defaults target))
+        (when (and (string= (name dist) (name new))
+                   (string/= (version dist) (version new)))
+          new)))))
+
+(defmethod update-release-differences ((old-dist dist)
+                                       (new-dist dist))
+  (let ((old-releases (provided-releases old-dist))
+        (new-releases (provided-releases new-dist))
+        (new '())
+        (updated '())
+        (removed '())
+        (old-by-name (make-hash-table :test 'equalp)))
+    (dolist (release old-releases)
+      (setf (gethash (name release) old-by-name)
+            release))
+    (dolist (new-release new-releases)
+      (let* ((name (name new-release))
+             (old-release (gethash name old-by-name)))
+        (remhash name old-by-name)
+        (cond ((not old-release)
+               (push new-release new))
+              ((not (equal (archive-content-sha1 new-release)
+                           (archive-content-sha1 old-release)))
+               (push (list old-release new-release) updated)))))
+    (maphash (lambda (name old-release)
+               (declare (ignore name))
+               (push old-release removed))
+             old-by-name)
+    (values (nreverse  new)
+            (nreverse  updated)
+            (sort removed #'string< :key #'prefix))))
+
+(defmethod show-update-report ((old-dist dist) (new-dist dist))
+  (multiple-value-bind (new updated removed)
+      (update-release-differences old-dist new-dist)
+    (format t "Changes from ~A ~A to ~A ~A:~%"
+            (name old-dist)
+            (version old-dist)
+            (name new-dist)
+            (version new-dist))
+    (when new
+      (format t "~&  New projects:~%")
+      (format t "~{    ~A~%~}" (mapcar #'prefix new)))
+    (when updated
+      (format t "~%  Updated projects:~%")
+      (loop for (old-release new-release) in updated
+            do (format t "    ~A -> ~A~%"
+                       (prefix old-release)
+                       (prefix new-release))))
+    (when removed
+      (format t "~%  Removed projects:~%")
+      (format t "~{    ~A~%~}" (mapcar #'prefix removed)))))
+
+(defun clear-dist-systems (dist)
+  (dolist (system (provided-systems dist))
+    (asdf:clear-system (name system))))
+
+(defmethod update-in-place :before ((old-dist dist) (new-dist dist))
+  ;; Make sure ASDF will reload any systems at their new locations
+  (clear-dist-systems old-dist))
+
+(defmethod update-in-place :after ((old-dist dist) (new-dist dist))
+  (clean new-dist))
+
+(defmethod update-in-place ((old-dist dist) (new-dist dist))
+  (flet ((remove-installed (type)
+           (let ((wild (merge-pathnames (make-pathname :directory
+                                                       (list :relative
+                                                             "installed"
+                                                             type)
+                                                       :name :wild
+                                                       :type "txt")
+                                        (base-directory old-dist))))
+             (dolist (file (directory wild))
+               (delete-file file)))))
+    (let ((reinstall-releases (installed-releases old-dist)))
+      (remove-installed "systems")
+      (remove-installed "releases")
+      (delete-file-if-exists (relative-to old-dist "releases.txt"))
+      (delete-file-if-exists (relative-to old-dist "systems.txt"))
+      (delete-file-if-exists (relative-to old-dist "releases.cdb"))
+      (delete-file-if-exists (relative-to old-dist "systems.cdb"))
+      (replace-file (local-distinfo-file new-dist)
+                    (local-distinfo-file old-dist))
+      (setf new-dist (find-dist (name new-dist)))
+      (dolist (old-release reinstall-releases)
+        (let* ((name (name old-release))
+               (new-release (find-release-in-dist name new-dist)))
+          (if new-release
+              (ensure-installed new-release)
+              (warn "~S is not available in ~A" name new-dist)))))))
+
+(defun install-dist (url &key (prompt t) replace)
+  (block nil
+    (setf url (url url))
+    (let ((temp-file (qmerge "tmp/install-dist-distinfo.txt")))
+      (ensure-directories-exist temp-file)
+      (delete-file-if-exists temp-file)
+      (fetch url temp-file)
+      (let* ((new-dist (make-dist-from-file temp-file))
+             (old-dist (find-dist (name new-dist))))
+        (when old-dist
+          (if replace
+              (uninstall old-dist)
+              (restart-case
+                  (error "A dist named ~S is already installed."
+                         (name new-dist))
+                (replace ()
+                  :report "Replace installed dist with new dist"
+                  (uninstall old-dist)))))
+        (format t "Installing dist ~S version ~S.~%"
+                (name new-dist)
+                (version new-dist))
+        (when (or (not prompt)
+                  (press-enter-to-continue))
+          (ensure-directories-exist (base-directory new-dist))
+          (copy-file temp-file (relative-to new-dist "distinfo.txt"))
+          (ensure-release-index-file new-dist)
+          (ensure-system-index-file new-dist)
+          (enable new-dist)
+          (setf (preference new-dist) (get-universal-time))
+          (when old-dist
+            (clear-dist-systems old-dist))
+          (clear-dist-systems new-dist)
+          new-dist)))))

sbcl/.quicklisp/quicklisp/fetch-gzipped.lisp

@@ -0,0 +1,29 @@
+;;;; fetch-gzipped.lisp
+
+(in-package #:quicklisp-client)
+
+(defun gzipped-url (url)
+  (check-type url string)
+  (concatenate 'string url ".gz"))
+
+(defun fetch-gzipped-version (url file &key quietly)
+  (let ((gzipped (gzipped-url url))
+        (gzipped-temp (merge-pathnames "gzipped.tmp" file)))
+    (fetch gzipped gzipped-temp :quietly quietly)
+    (gunzip gzipped-temp file)
+    (delete-file-if-exists gzipped-temp)
+    (probe-file file)))
+
+(defun url-not-suitable-error-p (condition)
+  (<= 400 (unexpected-http-status-code condition) 499))
+
+(defun maybe-fetch-gzipped (url file &key quietly)
+  (handler-case
+      (fetch-gzipped-version url file :quietly quietly)
+    (unexpected-http-status (condition)
+      (cond ((url-not-suitable-error-p condition)
+             (fetch url file :quietly quietly)
+             (probe-file file))
+            (t
+             (error condition))))))
+

sbcl/.quicklisp/quicklisp/http.lisp

@@ -0,0 +1,859 @@
+;;;
+;;; A simple HTTP client
+;;;
+
+(in-package #:ql-http)
+
+;;; Octet data
+
+(deftype octet ()
+  '(unsigned-byte 8))
+
+(defun make-octet-vector (size)
+  (make-array size :element-type 'octet
+              :initial-element 0))
+
+(defun octet-vector (&rest octets)
+  (make-array (length octets) :element-type 'octet
+              :initial-contents octets))
+
+;;; ASCII characters as integers
+
+(defun acode (char)
+  (cond ((eql char :cr)
+         13)
+        ((eql char :lf)
+         10)
+        (t
+         (let ((code (char-code char)))
+           (if (<= 0 code 127)
+               code
+               (error "Character ~S is not in the ASCII character set"
+                      char))))))
+
+(defvar *whitespace*
+  (list (acode #\Space) (acode #\Tab) (acode :cr) (acode :lf)))
+
+(defun whitep (code)
+  (member code *whitespace*))
+
+(defun ascii-vector (string)
+  (let ((vector (make-octet-vector (length string))))
+    (loop for char across string
+          for code = (char-code char)
+          for i from 0
+          if (< 127 code) do
+          (error "Invalid character for ASCII -- ~A" char)
+          else
+          do (setf (aref vector i) code))
+    vector))
+
+(defun ascii-subseq (vector start end)
+  "Return a subseq of octet-specialized VECTOR as a string."
+  (let ((string (make-string (- end start))))
+    (loop for i from 0
+          for j from start below end
+          do (setf (char string i) (code-char (aref vector j))))
+    string))
+
+(defun ascii-downcase (code)
+  (if (<= 65 code 90)
+      (+ code 32)
+      code))
+
+(defun ascii-equal (a b)
+  (eql (ascii-downcase a) (ascii-downcase b)))
+
+(defmacro acase (value &body cases)
+  (flet ((convert-case-keys (keys)
+           (mapcar (lambda (key)
+                     (etypecase key
+                       (integer key)
+                       (character (char-code key))
+                       (symbol
+                        (ecase key
+                          (:cr 13)
+                          (:lf 10)
+                          ((t) t)))))
+                   (if (consp keys) keys (list keys)))))
+    `(case ,value
+       ,@(mapcar (lambda (case)
+                   (destructuring-bind (keys &rest body)
+                       case
+                     `(,(if (eql keys t)
+                            t
+                            (convert-case-keys keys))
+                        ,@body)))
+                 cases))))
+
+;;; Pattern matching (for finding headers)
+
+(defclass matcher ()
+  ((pattern
+    :initarg :pattern
+    :reader pattern)
+   (pos
+    :initform 0
+    :accessor match-pos)
+   (matchedp
+    :initform nil
+    :accessor matchedp)))
+
+(defun reset-match (matcher)
+  (setf (match-pos matcher) 0
+        (matchedp matcher) nil))
+
+(define-condition match-failure (error) ())
+
+(defun match (matcher input &key (start 0) end error)
+  (let ((i start)
+        (end (or end (length input)))
+        (match-end (length (pattern matcher))))
+    (with-slots (pattern pos)
+        matcher
+      (loop
+       (cond ((= pos match-end)
+              (let ((match-start (- i pos)))
+                (setf pos 0)
+                (setf (matchedp matcher) t)
+                (return (values match-start (+ match-start match-end)))))
+             ((= i end)
+              (return nil))
+             ((= (aref pattern pos)
+                 (aref input i))
+              (incf i)
+              (incf pos))
+             (t
+              (if error
+                  (error 'match-failure)
+                  (if (zerop pos)
+                      (incf i)
+                      (setf pos 0)))))))))
+
+(defun ascii-matcher (string)
+  (make-instance 'matcher
+                 :pattern (ascii-vector string)))
+
+(defun octet-matcher (&rest octets)
+  (make-instance 'matcher
+                 :pattern (apply 'octet-vector octets)))
+
+(defun acode-matcher (&rest codes)
+  (make-instance 'matcher
+                 :pattern (make-array (length codes)
+                                      :element-type 'octet
+                                      :initial-contents
+                                      (mapcar 'acode codes))))
+
+
+;;; "Connection Buffers" are a kind of callback-driven,
+;;; pattern-matching chunky stream. Callbacks can be called for a
+;;; certain number of octets or until one or more patterns are seen in
+;;; the input. cbufs automatically refill themselves from a
+;;; connection as needed.
+
+(defvar *cbuf-buffer-size* 8192)
+
+(define-condition end-of-data (error) ())
+
+(defclass cbuf ()
+  ((data
+    :initarg :data
+    :accessor data)
+   (connection
+    :initarg :connection
+    :accessor connection)
+   (start
+    :initarg :start
+    :accessor start)
+   (end
+    :initarg :end
+    :accessor end)
+   (eofp
+    :initarg :eofp
+    :accessor eofp))
+  (:default-initargs
+   :data (make-octet-vector *cbuf-buffer-size*)
+   :connection nil
+   :start 0
+   :end 0
+   :eofp nil)
+  (:documentation "A CBUF is a connection buffer that keeps track of
+  incoming data from a connection. Several functions make it easy to
+  treat a CBUF as a kind of chunky, callback-driven stream."))
+
+(define-condition cbuf-progress ()
+  ((size
+    :initarg :size
+    :accessor cbuf-progress-size
+    :initform 0)))
+
+(defun call-processor (fun cbuf start end)
+  (signal 'cbuf-progress :size (- end start))
+  (funcall fun (data cbuf) start end))
+
+(defun make-cbuf (connection)
+  (make-instance 'cbuf :connection connection))
+
+(defun make-stream-writer (stream)
+  "Create a callback for writing data to STREAM."
+  (lambda (data start end)
+    (write-sequence data stream :start start :end end)))
+
+(defgeneric size (cbuf)
+  (:method ((cbuf cbuf))
+    (- (end cbuf) (start cbuf))))
+
+(defgeneric emptyp (cbuf)
+  (:method ((cbuf cbuf))
+    (zerop (size cbuf))))
+
+(defgeneric refill (cbuf)
+  (:method ((cbuf cbuf))
+    (when (eofp cbuf)
+      (error 'end-of-data))
+    (setf (start cbuf) 0)
+    (setf (end cbuf)
+          (read-octets (data cbuf)
+                       (connection cbuf)))
+    (cond ((emptyp cbuf)
+           (setf (eofp cbuf) t)
+           (error 'end-of-data))
+          (t (size cbuf)))))
+
+(defun process-all (fun cbuf)
+  (unless (emptyp cbuf)
+    (call-processor fun cbuf (start cbuf) (end cbuf))))
+
+(defun multi-cmatch (matchers cbuf)
+  (let (start end)
+    (dolist (matcher matchers (values start end))
+      (multiple-value-bind (s e)
+          (match matcher (data cbuf)
+                 :start (start cbuf)
+                 :end (end cbuf))
+        (when (and s (or (null start) (< s start)))
+          (setf start s
+                end e))))))
+
+(defun cmatch (matcher cbuf)
+  (if (consp matcher)
+      (multi-cmatch matcher cbuf)
+      (match matcher (data cbuf) :start (start cbuf) :end (end cbuf))))
+
+(defun call-until-end (fun cbuf)
+  (handler-case
+      (loop
+       (process-all fun cbuf)
+       (refill cbuf))
+    (end-of-data ()
+      (return-from call-until-end))))
+
+(defun show-cbuf (context cbuf)
+  (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf)))
+
+(defun call-for-n-octets (n fun cbuf)
+  (let ((remaining n))
+    (loop
+     (when (<= remaining (size cbuf))
+       (let ((end (+ (start cbuf) remaining)))
+         (call-processor fun cbuf (start cbuf) end)
+         (setf (start cbuf) end)
+         (return)))
+     (process-all fun cbuf)
+     (decf remaining (size cbuf))
+     (refill cbuf))))
+
+(defun call-until-matching (matcher fun cbuf)
+  (loop
+   (multiple-value-bind (start end)
+       (cmatch matcher cbuf)
+     (when start
+       (call-processor fun cbuf (start cbuf) end)
+       (setf (start cbuf) end)
+       (return)))
+   (process-all fun cbuf)
+   (refill cbuf)))
+
+(defun ignore-data (data start end)
+  (declare (ignore data start end)))
+
+(defun skip-until-matching (matcher cbuf)
+  (call-until-matching matcher 'ignore-data cbuf))
+
+
+;;; Creating HTTP requests as octet buffers
+
+(defclass octet-sink ()
+  ((storage
+    :initarg :storage
+    :accessor storage))
+  (:default-initargs
+   :storage (make-array 1024 :element-type 'octet
+                        :fill-pointer 0
+                        :adjustable t))
+  (:documentation "A simple stream-like target for collecting
+  octets."))
+
+(defun add-octet (octet sink)
+  (vector-push-extend octet (storage sink)))
+
+(defun add-octets (octets sink &key (start 0) end)
+  (setf end (or end (length octets)))
+  (loop for i from start below end
+        do (add-octet (aref octets i) sink)))
+
+(defun add-string (string sink)
+  (loop for char across string
+        for code = (char-code char)
+        do (add-octet code sink)))
+
+(defun add-strings (sink &rest strings)
+  (mapc (lambda (string) (add-string string sink)) strings))
+
+(defun add-newline (sink)
+  (add-octet 13 sink)
+  (add-octet 10 sink))
+
+(defun sink-buffer (sink)
+  (subseq (storage sink) 0))
+
+(defvar *proxy-url* (config-value "proxy-url"))
+
+(defun full-proxy-path (host port path)
+  (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A"
+          (eql port 443)
+          host
+          (or (null port)
+              (eql port 80)
+              (eql port 443))
+          port
+          path))
+
+(defun user-agent-string ()
+  "Return a string suitable for using as the User-Agent value in HTTP
+requests. Includes Quicklisp version and CL implementation and version
+information."
+  (labels ((requires-encoding (char)
+             (not (or (alphanumericp char)
+                      (member char '(#\. #\- #\_)))))
+           (encode (string)
+             (substitute-if #\_ #'requires-encoding string))
+           (version-string (string)
+             (if (string-equal string nil)
+                 "unknown"
+                 (let* ((length (length string))
+                        (start (or (position-if #'digit-char-p string)
+                                   0))
+                        (space (or (position #\Space string :start start)
+                                   length))
+                        (limit (min space length (+ start 24))))
+                   (encode (subseq string start limit))))))
+    ;; FIXME: Be more configurable, and take/set the version from
+    ;; somewhere else.
+    (format nil "quicklisp-client/~A ~A/~A"
+            ql-info:*version*
+            (encode (lisp-implementation-type))
+            (version-string (lisp-implementation-version)))))
+
+(defun make-request-buffer (host port path &key (method "GET"))
+  "Return an octet vector suitable for sending as an HTTP 1.1 request."
+  (setf method (string method))
+  (when *proxy-url*
+    (setf path (full-proxy-path host port path)))
+  (let ((sink (make-instance 'octet-sink)))
+    (flet ((add-line (&rest strings)
+             (apply #'add-strings sink strings)
+             (add-newline sink)))
+      (add-line method " " path " HTTP/1.1")
+      (add-line "Host: " host (if (integerp port)
+                                  (format nil ":~D" port)
+                                  ""))
+      (add-line "Connection: close")
+      (add-line "User-Agent: " (user-agent-string))
+      (add-newline sink)
+      (sink-buffer sink))))
+
+(defun sink-until-matching (matcher cbuf)
+  (let ((sink (make-instance 'octet-sink)))
+    (call-until-matching
+     matcher
+     (lambda (buffer start end)
+       (add-octets buffer sink :start start :end end))
+     cbuf)
+    (sink-buffer sink)))
+
+
+;;; HTTP headers
+
+(defclass header ()
+  ((data
+    :initarg :data
+    :accessor data)
+   (status
+    :initarg :status
+    :accessor status)
+   (name-starts
+    :initarg :name-starts
+    :accessor name-starts)
+   (name-ends
+    :initarg :name-ends
+    :accessor name-ends)
+   (value-starts
+    :initarg :value-starts
+    :accessor value-starts)
+   (value-ends
+    :initarg :value-ends
+    :accessor value-ends)))
+
+(defmethod print-object ((header header) stream)
+  (print-unreadable-object (header stream :type t)
+    (prin1 (status header) stream)))
+
+(defun matches-at (pattern target pos)
+  (= (mismatch pattern target :start2 pos) (length pattern)))
+
+(defun header-value-indexes (field-name header)
+  (loop with data = (data header)
+        with pattern = (ascii-vector (string-downcase field-name))
+        for start across (name-starts header)
+        for i from 0
+        when (matches-at pattern data start)
+        return (values (aref (value-starts header) i)
+                       (aref (value-ends header) i))))
+
+(defun ascii-header-value (field-name header)
+  (multiple-value-bind (start end)
+      (header-value-indexes field-name header)
+    (when start
+      (ascii-subseq (data header) start end))))
+
+(defun all-field-names (header)
+  (map 'list
+       (lambda (start end)
+         (ascii-subseq (data header) start end))
+       (name-starts header)
+       (name-ends header)))
+
+(defun headers-alist (header)
+  (mapcar (lambda (name)
+            (cons name (ascii-header-value name header)))
+          (all-field-names header)))
+
+(defmethod describe-object :after ((header header) stream)
+  (format stream "~&Decoded headers:~%  ~S~%" (headers-alist header)))
+
+(defun content-length (header)
+  (let ((field-value (ascii-header-value "content-length" header)))
+    (when field-value
+      (let ((value (ignore-errors (parse-integer field-value))))
+        (or value
+            (error "Content-Length header field value is not a number -- ~A"
+                   field-value))))))
+
+(defun chunkedp (header)
+  (string= (ascii-header-value "transfer-encoding" header) "chunked"))
+
+(defun location (header)
+  (ascii-header-value "location" header))
+
+(defun status-code (vector)
+  (let* ((space (position (acode #\Space) vector))
+         (c1 (- (aref vector (incf space)) 48))
+         (c2 (- (aref vector (incf space)) 48))
+         (c3 (- (aref vector (incf space)) 48)))
+    (+ (* c1 100)
+       (* c2  10)
+       (* c3   1))))
+
+(defun force-downcase-field-names (header)
+  (loop with data = (data header)
+        for start across (name-starts header)
+        for end across (name-ends header)
+        do (loop for i from start below end
+                 for code = (aref data i)
+                 do (setf (aref data i) (ascii-downcase code)))))
+
+(defun skip-white-forward (pos vector)
+  (position-if-not 'whitep vector :start pos))
+
+(defun skip-white-backward (pos vector)
+  (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t)))
+    (if nonwhite
+        (1+ nonwhite)
+        pos)))
+
+(defun contract-field-value-indexes (header)
+  "Header field values exclude leading and trailing whitespace; adjust
+the indexes in the header accordingly."
+  (loop with starts = (value-starts header)
+        with ends = (value-ends header)
+        with data = (data header)
+        for i from 0
+        for start across starts
+        for end across ends
+        do
+        (setf (aref starts i) (skip-white-forward start data))
+        (setf (aref ends i) (skip-white-backward end data))))
+
+(defun next-line-pos (vector)
+  (let ((pos 0))
+    (labels ((finish (&optional (i pos))
+               (return-from next-line-pos i))
+             (after-cr (code)
+               (acase code
+                 (:lf (finish pos))
+                 (t (finish (1- pos)))))
+             (pending (code)
+               (acase code
+                 (:cr #'after-cr)
+                 (:lf (finish pos))
+                 (t #'pending))))
+      (let ((state #'pending))
+        (loop
+         (setf state (funcall state (aref vector pos)))
+         (incf pos))))))
+
+(defun make-hvector ()
+  (make-array 16 :fill-pointer 0 :adjustable t))
+
+(defun process-header (vector)
+  "Create a HEADER instance from the octet data in VECTOR."
+  (let* ((name-starts (make-hvector))
+         (name-ends (make-hvector))
+         (value-starts (make-hvector))
+         (value-ends (make-hvector))
+         (header (make-instance 'header
+                                :data vector
+                                :status 999
+                                :name-starts name-starts
+                                :name-ends name-ends
+                                :value-starts value-starts
+                                :value-ends value-ends))
+         (mark nil)
+         (pos (next-line-pos vector)))
+    (unless pos
+      (error "Unable to process HTTP header"))
+    (setf (status header) (status-code vector))
+    (labels ((save (value vector)
+               (vector-push-extend value vector))
+             (mark ()
+               (setf mark pos))
+             (clear-mark ()
+               (setf mark nil))
+             (finish ()
+               (if mark
+                   (save mark value-ends)
+                   (save pos value-ends))
+              (force-downcase-field-names header)
+              (contract-field-value-indexes header)
+              (return-from process-header header))
+             (in-new-line (code)
+               (acase code
+                 ((#\Tab #\Space) (setf mark nil) #'in-value)
+                 (t
+                  (when mark
+                    (save mark value-ends))
+                  (clear-mark)
+                  (save pos name-starts)
+                  (in-name code))))
+             (after-cr (code)
+               (acase code
+                 (:lf #'in-new-line)
+                 (t (in-new-line code))))
+             (in-name (code)
+               (acase code
+                 (#\:
+                  (save pos name-ends)
+                  (save (1+ pos) value-starts)
+                  #'in-value)
+                 ((:cr :lf)
+                  (finish))
+                 ((#\Tab #\Space)
+                  (error "Unexpected whitespace in header field name"))
+                 (t
+                  (unless (<= 0 code 127)
+                    (error "Unexpected non-ASCII header field name"))
+                  #'in-name)))
+             (in-value (code)
+               (acase code
+                 (:lf (mark) #'in-new-line)
+                 (:cr (mark) #'after-cr)
+                 (t #'in-value))))
+      (let ((state #'in-new-line))
+        (loop
+         (incf pos)
+         (when (<= (length vector) pos)
+           (error "No header found in response"))
+         (setf state (funcall state (aref vector pos))))))))
+
+
+;;; HTTP URL parsing
+
+(defclass url ()
+  ((scheme
+    :initarg :scheme
+    :accessor scheme
+    :initform nil)
+   (hostname
+    :initarg :hostname
+    :accessor hostname
+    :initform nil)
+   (port
+    :initarg :port
+    :accessor port
+    :initform nil)
+   (path
+    :initarg :path
+    :accessor path
+    :initform "/")))
+
+(defun parse-urlstring (urlstring)
+  (setf urlstring (string-trim " " urlstring))
+  (let* ((pos (position #\: urlstring))
+         (scheme (or (and pos (subseq  urlstring 0 pos)) "http"))
+         (pos (mismatch urlstring "://" :test 'char-equal :start1 pos))
+         (mark pos)
+         (url (make-instance 'url)))
+    (setf (scheme url) scheme)
+    (labels ((save ()
+               (subseq urlstring mark pos))
+             (mark ()
+               (setf mark pos))
+             (finish ()
+               (return-from parse-urlstring url))
+             (hostname-char-p (char)
+               (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_."
+                         :test 'char-equal))
+             (at-start (char)
+               (case char
+                 (#\/
+                  (setf (port url) nil)
+                  (mark)
+                  #'in-path)
+                 (t
+                  #'in-host)))
+             (in-host (char)
+               (case char
+                 ((#\/ :end)
+                  (setf (hostname url) (save))
+                  (mark)
+                  #'in-path)
+                 (#\:
+                  (setf (hostname url) (save))
+                  (mark)
+                  #'in-port)
+                 (t
+                  (unless (hostname-char-p char)
+                    (error "~S is not a valid URL" urlstring))
+                  #'in-host)))
+             (in-port (char)
+               (case char
+                 ((#\/ :end)
+                  (setf (port url)
+                        (parse-integer urlstring
+                                       :start (1+ mark)
+                                       :end pos))
+                  (mark)
+                  #'in-path)
+                 (t
+                  (unless (digit-char-p char)
+                    (error "Bad port in URL ~S" urlstring))
+                  #'in-port)))
+             (in-path (char)
+               (case char
+                 ((#\# :end)
+                  (setf (path url) (save))
+                  (finish)))
+               #'in-path))
+      (let ((state #'at-start))
+        (loop
+         (when (<= (length urlstring) pos)
+           (funcall state :end)
+           (finish))
+         (setf state (funcall state (aref urlstring pos)))
+         (incf pos))))))
+
+(defun url (thing)
+  (if (stringp thing)
+      (parse-urlstring thing)
+      thing))
+
+(defgeneric request-buffer (method url)
+  (:method (method url)
+    (setf url (url url))
+    (make-request-buffer (hostname url) (or (port url) 80) (path url)
+                         :method method)))
+
+(defun urlstring (url)
+  (format nil "~@[~A://~]~@[~A~]~@[:~D~]~A"
+          (and (hostname url) (scheme url))
+          (hostname url)
+          (port url)
+          (path url)))
+
+(defmethod print-object ((url url) stream)
+  (print-unreadable-object (url stream :type t)
+    (prin1 (urlstring url) stream)))
+
+(defun merge-urls (url1 url2)
+  (setf url1 (url url1))
+  (setf url2 (url url2))
+  (make-instance 'url
+                 :scheme (or (scheme url1)
+                             (scheme url2))
+                 :hostname (or (hostname url1)
+                               (hostname url2))
+                 :port (or (port url1)
+                           (port url2))
+                 :path (or (path url1)
+                           (path url2))))
+
+
+;;; Requesting an URL and saving it to a file
+
+(defparameter *maximum-redirects* 10)
+(defvar *default-url-defaults* (url "http://src.quicklisp.org/"))
+
+(defun read-http-header (cbuf)
+  (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf)
+                                                (acode-matcher :cr :cr)
+                                                (acode-matcher :cr :lf :cr :lf))
+                                 cbuf)))
+    (process-header header-data)))
+
+(defun read-chunk-header (cbuf)
+  (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf))
+         (end (or (position (acode :cr) header-data)
+                  (position (acode #\;) header-data))))
+    (values (parse-integer (ascii-subseq header-data 0 end) :radix 16))))
+
+(defun save-chunk-response (stream cbuf)
+  "For a chunked response, read all chunks and write them to STREAM."
+  (let ((fun (make-stream-writer stream))
+        (matcher (acode-matcher :cr :lf)))
+    (loop
+     (let ((chunk-size (read-chunk-header cbuf)))
+       (when (zerop chunk-size)
+         (return))
+       (call-for-n-octets chunk-size fun cbuf)
+       (skip-until-matching matcher cbuf)))))
+
+(defun save-response (file header cbuf &key (if-exists :rename-and-delete))
+  (with-open-file (stream file
+                          :direction :output
+                          :if-exists if-exists
+                          :element-type 'octet)
+    (let ((content-length (content-length header)))
+      (cond ((chunkedp header)
+             (save-chunk-response stream cbuf))
+            (content-length
+             (call-for-n-octets content-length
+                                (make-stream-writer stream)
+                                cbuf))
+            (t
+             (call-until-end (make-stream-writer stream) cbuf))))))
+
+(defun call-with-progress-bar (size fun)
+  (let ((progress-bar (make-progress-bar size)))
+    (start-display progress-bar)
+    (flet ((update (condition)
+             (update-progress progress-bar
+                              (cbuf-progress-size condition))))
+      (handler-bind ((cbuf-progress #'update))
+        (funcall fun)))
+    (finish-display progress-bar)))
+
+(define-condition fetch-error (error) ())
+
+(define-condition unexpected-http-status (fetch-error)
+  ((status-code
+    :initarg :status-code
+    :reader unexpected-http-status-code)
+   (url
+    :initarg :url
+    :reader unexpected-http-status-url))
+  (:report
+   (lambda (condition stream)
+     (format stream "Unexpected HTTP status for ~A: ~A"
+             (unexpected-http-status-url condition)
+             (unexpected-http-status-code condition)))))
+
+(define-condition too-many-redirects (fetch-error)
+  ((url
+    :initarg :url
+    :reader too-many-redirects-url)
+   (redirect-count
+    :initarg :redirect-count
+    :reader too-many-redirects-count))
+  (:report
+   (lambda (condition stream)
+     (format stream "Too many redirects (~:D) for ~A"
+             (too-many-redirects-count condition)
+             (too-many-redirects-url condition)))))
+
+(defvar *fetch-scheme-functions*
+  '(("http" . http-fetch))
+  "assoc list to decide which scheme-function are called by FETCH function.")
+
+(defun fetch (url file &rest rest)
+  "Request URL and write the body of the response to FILE."
+  (let* ((url (merge-urls url *default-url-defaults*))
+         (call (cdr (assoc (scheme url) *fetch-scheme-functions* :test 'equal))))
+    (if call
+        (apply call (urlstring url) file rest)
+        (error "Unknown scheme ~S" url))))
+
+(defun http-fetch (url file &key (follow-redirects t) quietly
+              (if-exists :rename-and-delete)
+              (maximum-redirects *maximum-redirects*))
+  "default scheme-function for http protocol."
+  (setf url (merge-urls url *default-url-defaults*))
+  (setf file (merge-pathnames file))
+  (let ((redirect-count 0)
+        (original-url url)
+        (connect-url (or (url *proxy-url*) url))
+        (stream (if quietly
+                    (make-broadcast-stream)
+                    *trace-output*)))
+    (loop
+     (when (<= maximum-redirects redirect-count)
+       (error 'too-many-redirects
+              :url original-url
+              :redirect-count redirect-count))
+     (with-connection (connection (hostname connect-url) (or (port connect-url) 80))
+       (let ((cbuf (make-instance 'cbuf :connection connection))
+             (request (request-buffer "GET" url)))
+         (write-octets request connection)
+         (let ((header (read-http-header cbuf)))
+           (loop while (= (status header) 100)
+                 do (setf header (read-http-header cbuf)))
+           (cond ((= (status header) 200)
+                  (let ((size (content-length header)))
+                    (format stream "~&; Fetching ~A~%" url)
+                    (if (and (numberp size)
+                             (plusp size))
+                        (format stream "; ~$KB~%" (/ size 1024))
+                        (format stream "; Unknown size~%"))
+                    (if quietly
+                        (save-response file header cbuf
+                                       :if-exists if-exists)
+                        (call-with-progress-bar
+                         (content-length header)
+                         (lambda ()
+                           (save-response file header cbuf
+                                          :if-exists if-exists))))))
+                 ((not (<= 300 (status header) 399))
+                  (error 'unexpected-http-status
+                         :url url
+                         :status-code (status header))))
+           (if (and follow-redirects (<= 300 (status header) 399))
+               (let ((new-urlstring (ascii-header-value "location" header)))
+                 (when (not new-urlstring)
+                   (error "Redirect code ~D received, but no Location: header"
+                          (status header)))
+                 (incf redirect-count)
+                 (setf url (merge-urls new-urlstring
+                                       url))
+                 (format stream "~&; Redirecting to ~A~%" url))
+               (return (values header (and file (probe-file file)))))))))))

sbcl/.quicklisp/quicklisp/impl-util.lisp

@@ -0,0 +1,340 @@
+;;;; impl-util.lisp
+
+(in-package #:ql-impl-util)
+
+(definterface call-with-quiet-compilation (fun)
+  (:documentation
+   "Call FUN with warnings, style-warnings, and other verbose messages
+   suppressed.")
+  (:implementation t
+    (let ((*load-verbose* nil)
+          (*compile-verbose* nil)
+          (*load-print* nil)
+          (*compile-print* nil))
+      (handler-bind ((warning #'muffle-warning))
+        (funcall fun)))))
+
+(defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around)
+    (fun)
+  (declare (ignore fun))
+  (handler-bind ((ql-sbcl:compiler-note #'muffle-warning))
+    (call-next-method)))
+
+(defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around)
+    (fun)
+  (declare (ignore fun))
+  (let ((ql-cmucl:*gc-verbose* nil))
+    (call-next-method)))
+
+(definterface rename-directory (from to)
+  (:implementation t
+    (rename-file from to)
+    (truename to))
+  (:implementation cmucl
+    (rename-file from (string-right-trim "/" (namestring to)))
+    (truename to))
+  (:implementation clisp
+    (ql-clisp:rename-directory from to)
+    (truename to)))
+
+(definterface probe-directory (pathname)
+  (:documentation "Return the truename of PATHNAME, if it exists and
+  is a directory, or NIL otherwise.")
+  (:implementation t
+    (let ((directory (probe-file pathname)))
+      (when directory
+        ;; probe-file is specified to return the truename of the path,
+        ;; but Allegro does not return the truename; truenamize it.
+        (truename directory))))
+  (:implementation clisp
+    (let ((directory (ql-clisp:probe-pathname pathname)))
+      (when (and directory (ql-clisp:probe-directory directory))
+        directory))))
+
+(definterface init-file-name ()
+  (:documentation "Return the init file name for the current implementation.")
+  (:implementation allegro
+    ".clinit.cl")
+  (:implementation abcl
+    ".abclrc")
+  (:implementation ccl
+    #+windows
+    "ccl-init.lisp"
+    #-windows
+    ".ccl-init.lisp")
+  (:implementation clasp
+    ".clasprc")
+  (:implementation clisp
+    ".clisprc.lisp")
+  (:implementation ecl
+    ".eclrc")
+  (:implementation mkcl
+    ".mkclrc")
+  (:implementation lispworks
+    ".lispworks")
+  (:implementation sbcl
+    ".sbclrc")
+  (:implementation cmucl
+    ".cmucl-init.lisp")
+  (:implementation scl
+    ".scl-init.lisp")
+  )
+
+(defun init-file-name-for (&optional implementation-designator)
+  (let* ((class-name (find-symbol (string-upcase implementation-designator)
+                                  'ql-impl))
+         (class (find-class class-name nil)))
+    (when class
+      (let ((*implementation* (make-instance class)))
+        (init-file-name)))))
+
+(defun quicklisp-init-file-form ()
+  "Return a form suitable for describing the location of the quicklisp
+  init file. If the file is available relative to the home directory,
+  returns a form that merges with the home directory instead of
+  specifying an absolute file."
+  (let* ((init-file (ql-setup:qmerge "setup.lisp"))
+         (enough (enough-namestring init-file (user-homedir-pathname))))
+    (cond ((equal (pathname enough) (pathname init-file))
+           ;; The init-file is somewhere outside of the home directory
+           (pathname enough))
+          (t
+           `(merge-pathnames ,enough (user-homedir-pathname))))))
+
+(defun write-init-forms (stream &key (indentation 0))
+  (format stream "~%~v@T;;; The following lines added by ql:add-to-init-file:~%"
+          indentation)
+  (format stream "~v@T#-quicklisp~%" indentation)
+  (let ((*print-case* :downcase))
+    (format stream "~v@T(let ((quicklisp-init ~S))~%"
+            indentation
+            (quicklisp-init-file-form)))
+  (format stream "~v@T  (when (probe-file quicklisp-init)~%" indentation)
+  (format stream "~v@T    (load quicklisp-init)))~%~%" indentation))
+
+(defun suitable-lisp-init-file (implementation)
+  "Return the name of IMPLEMENTATION's init file. If IMPLEMENTAION is
+a string or pathname, return its merged pathname instead."
+  (typecase implementation
+    ((or string pathname)
+     (merge-pathnames implementation))
+    ((or null (eql t))
+     (init-file-name))
+    (t
+     (init-file-name-for implementation))))
+
+(defun add-to-init-file (&optional implementation-or-file)
+  "Add forms to the Lisp implementation's init file that will load
+quicklisp at CL startup."
+  (let ((init-file (suitable-lisp-init-file implementation-or-file)))
+    (unless init-file
+      (error "Don't know how to add to init file for your implementation."))
+    (setf init-file (merge-pathnames init-file (user-homedir-pathname)))
+    (format *query-io* "~&I will append the following lines to ~S:~%"
+            init-file)
+    (write-init-forms *query-io* :indentation 2)
+    (when (ql-util:press-enter-to-continue)
+      (with-open-file (stream init-file
+                              :direction :output
+                              :if-does-not-exist :create
+                              :if-exists :append)
+        (write-init-forms stream)))
+    init-file))
+
+
+
+;;;
+;;; Native namestrings.
+;;;
+
+(definterface native-namestring (pathname)
+  (:documentation "In Clozure CL, #\\.s in pathname-names are escaped
+  in namestrings with #\\> on Windows and #\\\\ elsewhere. This can
+  cause a problem when using CL:NAMESTRING to store pathname data that
+  might be used by other implementations. NATIVE-NAMESTRING is
+  intended to provide a namestring that can be parsed as a same-enough
+  object on multiple implementations.")
+  (:implementation t
+    (namestring pathname))
+  (:implementation ccl
+    (ql-ccl:native-translated-namestring pathname))
+  (:implementation sbcl
+    (ql-sbcl:native-namestring pathname)))
+
+
+;;;
+;;; Directory write date
+;;;
+
+(definterface directory-write-date (pathname)
+  (:documentation "Return the write-date of the directory designated
+  by PATHNAME as a universal time, like file-write-date.")
+  (:implementation t
+    (file-write-date pathname))
+  (:implementation clisp
+    (nth-value 2 (ql-clisp:probe-pathname pathname))))
+
+
+;;;
+;;; Deleting a directory tree
+;;;
+
+(defvar *wild-entry*
+  (make-pathname :name :wild :type :wild :version :wild))
+
+(defvar *wild-relative*
+  (make-pathname :directory '(:relative :wild)))
+
+(definterface directoryp (entry)
+  (:documentation "Return true if ENTRY refers to a directory.")
+  (:implementation t
+    (not (or (pathname-name entry)
+             (pathname-type entry))))
+  (:implementation allegro
+    (ql-allegro:file-directory-p entry))
+  (:implementation lispworks
+    (ql-lispworks:file-directory-p entry)))
+
+(definterface directory-entries (directory)
+  (:documentation "Return all directory entries of DIRECTORY as a
+  list, or NIL if there are no directory entries. Excludes the \".\"
+  and \"..\" entries.")
+  (:implementation allegro
+    (directory directory
+               #+allegro :directories-are-files
+               #+allegro nil
+               #+allegro :follow-symbolic-links
+               #+allegro nil))
+  (:implementation abcl
+    (directory (merge-pathnames *wild-entry* directory)
+               #+abcl :resolve-symlinks #+abcl nil))
+  (:implementation ccl
+    (directory (merge-pathnames *wild-entry* directory)
+               #+ccl :directories #+ccl t
+               #+ccl :follow-links #+ccl nil))
+  (:implementation clasp
+    (nconc
+     (directory (merge-pathnames *wild-entry* directory)
+                #+clasp :resolve-symlinks #+clasp nil)
+     (directory (merge-pathnames *wild-relative* directory)
+                #+clasp :resolve-symlinks #+clasp nil)))
+  (:implementation clisp
+    ;; :full gives pathnames as well as truenames, BUT: it returns a
+    ;; singleton pathname, not a list, on dead symlinks.
+    (remove nil
+            (mapcar (lambda (entry) (and (listp entry) (first entry)))
+                    (nconc (directory (merge-pathnames *wild-entry* directory)
+                                      #+clisp :full #+clisp t
+                                      #+clisp :if-does-not-exist #+clisp :keep)
+                           (directory (merge-pathnames *wild-relative* directory)
+                                      #+clisp :full #+clisp t
+                                      #+clisp :if-does-not-exist #+clisp :keep)))))
+  (:implementation cmucl
+    (directory (merge-pathnames *wild-entry* directory)
+               #+cmucl :truenamep #+cmucl nil))
+  (:implementation scl
+    (directory (merge-pathnames *wild-entry* directory)
+               #+scl :truenamep #+scl nil))
+  (:implementation lispworks
+    (directory (merge-pathnames *wild-entry* directory)
+               #+lispworks :directories #+lispworks t
+               #+lispworks :link-transparency #+lispworks nil))
+  (:implementation ecl
+    (nconc
+     (directory (merge-pathnames *wild-entry* directory)
+                #+ecl :resolve-symlinks #+ecl nil)
+     (directory (merge-pathnames *wild-relative* directory)
+                #+ecl :resolve-symlinks #+ecl nil)))
+  (:implementation mkcl
+    (setf directory (truename directory))
+    (nconc
+     (directory (merge-pathnames *wild-entry* directory))
+     (directory (merge-pathnames *wild-relative* directory))))
+  (:implementation sbcl
+    (directory (merge-pathnames *wild-entry* directory)
+               #+sbcl :resolve-symlinks #+sbcl nil)))
+
+(defimplementation (directory-entries :qualifier :around) (directory)
+  ;; Don't return any entries when called with a non-directory
+  ;; argument
+  (if (directoryp directory)
+      (call-next-method)
+      (warn "directory-entries - not a directory -- ~S" directory)))
+
+(definterface delete-directory (entry)
+  (:documentation "Delete the directory ENTRY. Might signal an error
+  if it is not an empty directory.")
+  (:implementation t
+    (delete-file entry))
+  (:implementation allegro
+    (ql-allegro:delete-directory entry))
+  (:implementation ccl
+    (ql-ccl:delete-directory entry))
+  (:implementation clasp
+    (ql-clasp:rmdir entry))
+  (:implementation clisp
+    (ql-clisp:delete-directory entry))
+  (:implementation cmucl
+    (ql-cmucl:unix-rmdir (namestring entry)))
+  (:implementation scl
+    (ql-scl:unix-rmdir (ql-scl:unix-namestring entry)))
+  (:implementation ecl
+    (ql-ecl:rmdir entry))
+  (:implementation mkcl
+    (ql-mkcl:rmdir entry))
+  (:implementation lispworks
+    (ql-lispworks:delete-directory entry))
+  (:implementation sbcl
+    (ql-sbcl:rmdir entry)))
+
+(defimplementation (delete-directory :qualifier :around) (directory)
+  ;; Don't delete non-directories with delete-directory
+  (if (directoryp directory)
+      (call-next-method)
+      (error "delete-directory - not a directory -- ~A" directory)))
+
+(definterface delete-directory-tree (pathname)
+  (:documentation "Delete the directory tree rooted at PATHNAME.")
+  (:implementation t
+    (let ((directories-to-process (list (truename pathname)))
+          (directories-to-delete '()))
+      (loop
+        (unless directories-to-process
+          (return))
+        (let* ((current (pop directories-to-process))
+               (entries (directory-entries current)))
+          (push current directories-to-delete)
+          (dolist (entry entries)
+            (if (directoryp entry)
+                (push entry directories-to-process)
+                (delete-file entry)))))
+      (map nil 'delete-directory directories-to-delete)))
+  (:implementation allegro
+    (ql-allegro:delete-directory-and-files pathname))
+  (:implementation ccl
+    (ql-ccl:delete-directory pathname)))
+
+(defimplementation (delete-directory-tree :qualifier :around) (pathname)
+  (if (directoryp pathname)
+      (call-next-method)
+      (progn
+        (warn "delete-directory-tree - not a directory, ~
+               deleting anyway -- ~s" pathname)
+        (delete-file pathname))))
+
+(defun map-directory-tree (directory fun)
+  "Call FUN for every file in directory and all its subdirectories,
+recursively. Uses the truename of directory as a starting point. Does
+not follow symlinks, but, on some implementations, DOES include
+potentially dead symlinks."
+  (let ((directories-to-process (list (truename directory))))
+    (loop
+      (unless directories-to-process
+        (return))
+      (let* ((current (pop directories-to-process))
+             (entries (directory-entries current)))
+        (dolist (entry entries)
+          (if (directoryp entry)
+              (push entry directories-to-process)
+              (funcall fun entry)))))))
+

sbcl/.quicklisp/quicklisp/impl.lisp

@@ -0,0 +1,301 @@
+(in-package #:ql-impl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun error-unimplemented (&rest args)
+    (declare (ignore args))
+    (error "Not implemented")))
+
+(defvar *interfaces* (make-hash-table)
+  "A table of defined interfaces and their documentation.")
+
+(defun show-interfaces ()
+  "Display information about what interfaces are defined."
+  (maphash (lambda (interface info)
+             (destructuring-bind (arguments docstring)
+                 info
+               (let ((*package* (find-package :keyword)))
+                 (format t "(~S ~:[()~;~:*~A~]~@[~% ~S~])~%"
+                         interface arguments docstring))))
+           *interfaces*))
+
+(defmacro neuter-package (name)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (let ((definition (fdefinition 'error-unimplemented)))
+       (do-external-symbols (symbol ,(string name))
+         (unless (fboundp symbol)
+           (setf (fdefinition symbol) definition))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun feature-expression-passes-p (expression)
+    (cond ((keywordp expression)
+           (member expression *features*))
+          ((consp expression)
+           (case (first expression)
+             (or
+              (some 'feature-expression-passes-p (rest expression)))
+             (and
+              (every 'feature-expression-passes-p (rest expression)))))
+          (t (error "Unrecognized feature expression -- ~S" expression)))))
+
+
+(defmacro define-implementation-package (feature package-name &rest options)
+  (let* ((output-options '((:use)
+                           (:export #:lisp)))
+         (prep (cdr (assoc :prep options)))
+         (class-option (cdr (assoc :class options)))
+         (class (first class-option))
+         (superclasses (rest class-option))
+         (import-options '())
+         (effectivep (feature-expression-passes-p feature)))
+    (dolist (option options)
+      (ecase (first option)
+        ((:prep :class))
+        ((:import-from
+          :import)
+         (push option import-options))
+        ((:export
+          :shadow
+          :intern
+          :documentation)
+         (push option output-options))
+        ((:reexport-from)
+         (push (cons :export (cddr option)) output-options)
+         (push (cons :import-from (cdr option)) import-options))))
+    `(progn
+       ,@(when effectivep
+               `((eval-when (:compile-toplevel :load-toplevel :execute)
+                   ,@prep)))
+       (defclass ,class ,superclasses ())
+       (defpackage ,package-name ,@output-options
+                   ,@(when effectivep
+                           import-options))
+       ,@(when effectivep
+               `((setf *implementation* (make-instance ',class))))
+       ,@(unless effectivep
+                 `((neuter-package ,package-name))))))
+
+(defmacro definterface (name lambda-list &body options)
+  (let* ((doc-option (find :documentation options :key #'first))
+         (doc (second doc-option)))
+    (setf (gethash name *interfaces*) (list lambda-list doc)))
+  (let* ((forbidden (intersection lambda-list lambda-list-keywords))
+         (gf-options (remove :implementation options :key #'first))
+         (implementations (set-difference options gf-options))
+         (implementation-arg (copy-symbol '%implementation)))
+    (when forbidden
+      (error "~S not allowed in definterface lambda list" forbidden))
+    (flet ((method-option (class body)
+             `(:method ((,implementation-arg ,class) ,@lambda-list)
+                ,@body)))
+      (let ((generic-name (intern (format nil "%~A" name))))
+        `(progn
+           (defgeneric ,generic-name (lisp ,@lambda-list)
+             ,@gf-options
+             ,@(mapcan (lambda (implementation)
+                         (destructuring-bind (class &rest body)
+                             (rest implementation)
+                           (mapcar (lambda (class)
+                                     (method-option class body))
+                                   (if (consp class)
+                                       class
+                                       (list class)))))
+                       implementations))
+           (defun ,name ,lambda-list
+             (,generic-name *implementation* ,@lambda-list)))))))
+
+(defmacro defimplementation (name-and-options
+                             lambda-list &body body)
+  (destructuring-bind (name &key (for t) qualifier)
+      (if (consp name-and-options)
+          name-and-options
+          (list name-and-options))
+    (unless for
+      (error "You must specify an implementation name."))
+    (let ((generic-name (find-symbol (format nil "%~A" name)))
+          (implementation-arg (copy-symbol '%implementation)))
+      (unless generic-name
+        (error "~S does not name an implementation function" name))
+      `(defmethod ,generic-name
+           ,@(when qualifier (list qualifier))
+         ,(list* `(,implementation-arg ,for) lambda-list) ,@body))))
+
+
+;;; Bootstrap implementations
+
+(defvar *implementation* nil)
+(defclass lisp () ())
+
+
+;;; Allegro Common Lisp
+
+(define-implementation-package :allegro #:ql-allegro
+  (:documentation
+   "Allegro Common Lisp - http://www.franz.com/products/allegrocl/")
+  (:class allegro)
+  (:reexport-from #:socket
+                  #:make-socket)
+  (:reexport-from #:excl
+                  #:file-directory-p
+                  #:delete-directory
+                  #:delete-directory-and-files
+                  #:read-vector))
+
+
+;;; Armed Bear Common Lisp
+
+(define-implementation-package :abcl #:ql-abcl
+  (:documentation
+   "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/")
+  (:class abcl)
+  (:reexport-from #:ext
+                  #:make-socket
+                  #:get-socket-stream))
+
+;;; Clozure CL
+
+(define-implementation-package :ccl #:ql-ccl
+  (:documentation
+   "Clozure Common Lisp - http://www.clozure.com/clozurecl.html")
+  (:class ccl)
+  (:reexport-from #:ccl
+                  #:delete-directory
+                  #:make-socket
+                  #:native-translated-namestring))
+
+;;; CLASP
+
+(define-implementation-package :clasp #:ql-clasp
+  (:documentation "CLASP - http://github.com/drmeister/clasp")
+  (:class clasp)
+  (:prep
+   (require 'sockets))
+  (:intern #:host-network-address)
+  (:reexport-from #:si
+                  #:rmdir
+                  #:file-kind)
+  (:reexport-from #:sb-bsd-sockets
+                  #:get-host-by-name
+                  #:host-ent-address
+                  #:inet-socket
+                  #:socket-connect
+                  #:socket-make-stream))
+
+
+;;; GNU CLISP
+
+(define-implementation-package :clisp #:ql-clisp
+  (:documentation "GNU CLISP - http://clisp.cons.org/")
+  (:class clisp)
+  (:reexport-from #:socket
+                  #:socket-connect)
+  (:reexport-from #:ext
+                  #:delete-directory
+                  #:rename-directory
+                  #:probe-directory
+                  #:probe-pathname
+                  #:read-byte-sequence))
+
+
+;;; CMUCL
+
+(define-implementation-package :cmu #:ql-cmucl
+  (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/")
+  (:class cmucl)
+  (:reexport-from #:system
+                  #:make-fd-stream)
+  (:reexport-from #:unix
+                  #:unix-rmdir)
+  (:reexport-from #:extensions
+                  #:connect-to-inet-socket
+                  #:*gc-verbose*))
+
+(defvar ql-cmucl:*gc-verbose*)
+
+
+;;; Scieneer CL
+
+(define-implementation-package :scl #:ql-scl
+  (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/")
+  (:class scl)
+  (:reexport-from #:system
+                  #:make-fd-stream)
+  (:reexport-from #:unix
+                  #:unix-rmdir)
+  (:reexport-from #:extensions
+                  #:connect-to-inet-socket
+                  #:unix-namestring))
+
+
+;;; LispWorks
+
+(define-implementation-package :lispworks #:ql-lispworks
+  (:documentation "LispWorks - http://www.lispworks.com/")
+  (:class lispworks)
+  (:prep
+   (require "comm"))
+  (:reexport-from #:lw
+                  #:file-directory-p
+                  #:delete-directory)
+  (:reexport-from #:comm
+                  #:open-tcp-stream
+                  #:get-host-entry))
+
+
+;;; ECL
+
+(define-implementation-package :ecl #:ql-ecl
+  (:documentation "ECL - http://ecls.sourceforge.net/")
+  (:class ecl)
+  (:prep
+   (require 'sockets))
+  (:intern #:host-network-address)
+  (:reexport-from #:si
+                  #:rmdir
+                  #:file-kind)
+  (:reexport-from #:sb-bsd-sockets
+                  #:get-host-by-name
+                  #:host-ent-address
+                  #:inet-socket
+                  #:socket-connect
+                  #:socket-make-stream))
+
+;;; MKCL
+
+(define-implementation-package :mkcl #:ql-mkcl
+  (:documentation "ManKai Common Lisp - http://common-lisp.net/project/mkcl/")
+  (:class mkcl)
+  (:prep
+   (require 'sockets))
+  (:intern #:host-network-address)
+  (:reexport-from #:si
+                  #:rmdir
+                  #:file-kind)
+  (:reexport-from #:sb-bsd-sockets
+                  #:get-host-by-name
+                  #:host-ent-address
+                  #:inet-socket
+                  #:socket-connect
+                  #:socket-make-stream))
+
+
+;;; SBCL
+
+(define-implementation-package :sbcl #:ql-sbcl
+  (:class sbcl)
+  (:documentation
+   "Steel Bank Common Lisp - http://www.sbcl.org/")
+  (:prep
+   (require 'sb-posix)
+   (require 'sb-bsd-sockets))
+  (:intern #:host-network-address)
+  (:reexport-from #:sb-posix
+                  #:rmdir)
+  (:reexport-from #:sb-ext
+                  #:compiler-note
+                  #:native-namestring)
+  (:reexport-from #:sb-bsd-sockets
+                  #:get-host-by-name
+                  #:inet-socket
+                  #:host-ent-address
+                  #:socket-connect
+                  #:socket-make-stream))

sbcl/.quicklisp/quicklisp/local-projects.lisp

@@ -0,0 +1,138 @@
+;;;; local-projects.lisp
+
+;;;
+;;; Local project support.
+;;;
+;;; Local projects can be placed in <quicklisp>/local-projects/. New
+;;; entries in that directory are automatically scanned for system
+;;; files for use with QL:QUICKLOAD.
+;;;
+;;; This works by keeping a cache of system file pathnames in
+;;; <quicklisp>/local-projects/system-index.txt. Whenever the
+;;; timestamp on the local projects directory is newer than the
+;;; timestamp on the system index file, the entire tree is re-scanned
+;;; and cached.
+;;;
+;;; This will pick up system files that are created as a result of
+;;; creating new project directory in <quicklisp>/local-projects/,
+;;; e.g. unpacking a tarball or zip file, checking out a project from
+;;; version control, etc. It will NOT pick up a system file that is
+;;; added sometime later in a subdirectory; for that, the
+;;; REGISTER-LOCAL-PROJECTS function is needed to rebuild the system
+;;; file index.
+;;;
+;;; In the event there are multiple systems of the same name in the
+;;; directory tree, the one with the shortest pathname namestring is
+;;; used. This is intended to ignore stuff like _darcs pristine
+;;; directories.
+;;;
+;;; Work in progress!
+;;;
+
+(in-package #:quicklisp-client)
+
+(defparameter *local-project-directories*
+  (list (qmerge "local-projects/"))
+  "The default local projects directory.")
+
+(defun system-index-file (pathname)
+  "Return the system index file for the directory PATHNAME."
+  (merge-pathnames "system-index.txt" pathname))
+
+(defun matching-directory-files (directory fun)
+  (let ((result '()))
+    (map-directory-tree directory
+                        (lambda (file)
+                          (when (funcall fun file)
+                            (push file result))))
+    result))
+
+(defun local-project-system-files (pathname)
+  "Return a list of system files under PATHNAME."
+  (let* ((files (matching-directory-files pathname
+                                          (lambda (file)
+                                            (equalp (pathname-type file)
+                                                    "asd")))))
+    (setf files (sort files
+                      #'string<
+                      :key #'namestring))
+    (stable-sort files
+                 #'<
+                 :key (lambda (file)
+                        (length (namestring file))))))
+
+(defun make-system-index (pathname)
+  "Create a system index file for all system files under
+PATHNAME. Current format is one native namestring per line."
+  (setf pathname (truename pathname))
+  (with-open-file (stream (system-index-file pathname)
+                          :direction :output
+                          :if-exists :rename-and-delete)
+    (dolist (system-file (local-project-system-files pathname))
+      (let ((system-path (enough-namestring system-file pathname)))
+        (write-line (native-namestring system-path) stream)))
+    (probe-file stream)))
+
+(defun find-valid-system-index (pathname)
+  "Find a valid system index file for PATHNAME; one that both exists
+and has a newer timestamp than PATHNAME."
+  (let* ((file (system-index-file pathname))
+         (probed (probe-file file)))
+    (when (and probed
+               (<= (directory-write-date pathname)
+                   (file-write-date probed)))
+      probed)))
+
+(defun ensure-system-index (pathname)
+  "Find or create a system index file for PATHNAME."
+  (or (find-valid-system-index pathname)
+      (make-system-index pathname)))
+
+(defun find-system-in-index (system index-file)
+  "If any system pathname in INDEX-FILE has a pathname-name matching
+SYSTEM, return its full pathname."
+  (with-open-file (stream index-file)
+    (loop for namestring = (read-line stream nil)
+          while namestring
+          when (string= system (pathname-name namestring))
+          return (or (probe-file (merge-pathnames namestring index-file))
+                     ;; If the indexed .asd file doesn't exist anymore
+                     ;; then regenerate the index and restart the search.
+                     (find-system-in-index system (make-system-index (directory-namestring index-file)))))))
+
+(defun local-projects-searcher (system-name)
+  "This function is added to ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*
+to use the local project directory and cache to find systems."
+  (dolist (directory *local-project-directories*)
+    (when (probe-directory directory)
+      (let ((system-index (ensure-system-index directory)))
+        (when system-index
+          (let ((system (find-system-in-index system-name system-index)))
+            (when system
+              (return system))))))))
+
+(defun list-local-projects ()
+  "Return a list of pathnames to local project system files."
+  (let ((result (make-array 16 :fill-pointer 0 :adjustable t))
+        (seen (make-hash-table :test 'equal)))
+    (dolist (directory *local-project-directories*
+             (coerce result 'list))
+      (let ((index (ensure-system-index directory)))
+        (when index
+          (with-open-file (stream index)
+            (loop for line = (read-line stream nil)
+                  while line do
+                  (let ((pathname (merge-pathnames line index)))
+                    (unless (gethash (pathname-name pathname) seen)
+                      (setf (gethash (pathname-name pathname) seen) t)
+                      (vector-push-extend (merge-pathnames line index)
+                                          result))))))))))
+
+(defun register-local-projects ()
+  "Force a scan of the local projects directory to create the system
+file index."
+  (map nil 'make-system-index *local-project-directories*))
+
+(defun list-local-systems ()
+  "Return a list of local project system names."
+  (mapcar #'pathname-name (list-local-projects)))

sbcl/.quicklisp/quicklisp/minitar.lisp

@@ -0,0 +1,192 @@
+(in-package #:ql-minitar)
+
+(defconstant +block-size+ 512)
+(defconstant +space-code+ 32)
+(defconstant +newline-code+ 10)
+(defconstant +equals-code+ 61)
+
+(defun make-block-buffer ()
+  (make-array +block-size+ :element-type '(unsigned-byte 8) :initial-element 0))
+
+(defun skip-n-blocks (n stream)
+  (let ((block (make-block-buffer)))
+    (dotimes (i n)
+      (read-sequence block stream))))
+
+(defun read-octet-vector (length stream)
+  (let ((block (make-block-buffer))
+        (vector (make-array length :element-type '(unsigned-byte 8)))
+        (offset 0)
+        (block-count (ceiling length +block-size+)))
+    (dotimes (i block-count)
+        (read-sequence block stream)
+        (replace vector block :start1 offset)
+        (incf offset +block-size+))
+    vector))
+
+
+(defun decode-pax-header-record (vector offset)
+  "Decode VECTOR as pax extended header data. Returns the keyword and
+value it specifies as multiple values."
+  ;; Vector format is: "%d %s=%s\n", <length>, <keyword>, <value>
+  ;; See http://pubs.opengroup.org/onlinepubs/009695399/utilities/pax.html
+  (let* ((length-start offset)
+         (length-end (position +space-code+ vector :start length-start))
+         (length-string (ascii-subseq vector length-start length-end))
+         (length (parse-integer length-string))
+         (keyword-start (1+ length-end))
+         (keyword-end (position +equals-code+ vector :start keyword-start))
+         (keyword (ascii-subseq vector keyword-start keyword-end))
+         (value-start (1+ keyword-end))
+         (value-end (1- (+ offset length)))
+         (value (ascii-subseq vector value-start value-end)))
+    (values keyword value (+ offset length))))
+
+(defun decode-pax-header (vector)
+  "Decode VECTOR as a pax header and return it as an alist."
+  (let ((header nil)
+        (offset 0)
+        (length (length vector)))
+    (loop
+      (when (<= length offset)
+        (return header))
+      (multiple-value-bind (keyword value new-offset)
+          (decode-pax-header-record vector offset)
+        (setf header (acons keyword value header))
+        (setf offset new-offset)))))
+
+(defun pax-header-path (vector)
+  "Decode VECTOR as a pax header and return its 'path' value, if
+  any."
+  (let ((header-alist (decode-pax-header vector)))
+    (cdr (assoc "path" header-alist :test 'equal))))
+
+(defun ascii-subseq (vector start end)
+  (let ((string (make-string (- end start))))
+    (loop for i from 0
+          for j from start below end
+          do (setf (char string i) (code-char (aref vector j))))
+    string))
+
+(defun block-asciiz-string (block start length)
+  (let* ((end (+ start length))
+         (eos (or (position 0 block :start start :end end)
+                            end)))
+    (ascii-subseq block start eos)))
+
+(defun prefix (header)
+  (when (plusp (aref header 345))
+    (block-asciiz-string header 345 155)))
+
+(defun name (header)
+  (block-asciiz-string header 0 100))
+
+(defun payload-size (header)
+  (values (parse-integer (block-asciiz-string header 124 12) :radix 8)))
+
+(defun nth-block (n file)
+  (with-open-file (stream file :element-type '(unsigned-byte 8))
+    (let ((block (make-block-buffer)))
+      (skip-n-blocks (1- n) stream)
+      (read-sequence block stream)
+      block)))
+
+(defun payload-type (code)
+  (case code
+    (0 :file)
+    (48 :file)
+    (50 :symlink)
+    (76 :long-name)
+    (53 :directory)
+    (103 :global-header)
+    (120 :pax-extended-header)
+    (t :unsupported)))
+
+(defun full-path (header)
+  (let ((prefix (prefix header))
+        (name (name header)))
+    (if prefix
+        (format nil "~A/~A" prefix name)
+        name)))
+
+(defun save-file (file size stream)
+  (multiple-value-bind (full-blocks partial)
+      (truncate size +block-size+)
+    (ensure-directories-exist file)
+    (with-open-file (outstream file
+                     :direction :output
+                     :if-exists :supersede
+                     :element-type '(unsigned-byte 8))
+      (let ((block (make-block-buffer)))
+        (dotimes (i full-blocks)
+          (read-sequence block stream)
+          (write-sequence block outstream))
+        (when (plusp partial)
+          (read-sequence block stream)
+          (write-sequence block outstream :end partial))))))
+
+(defun gnu-long-name (size stream)
+  ;; GNU long names are simply the filename (null terminated) packed into the
+  ;; payload.
+  (let ((payload (read-octet-vector size stream)))
+    (ascii-subseq payload 0 (1- size))))
+
+(defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*))
+  (let ((block (make-block-buffer))
+        (extended-path nil))
+    (with-open-file (stream tarfile :element-type '(unsigned-byte 8))
+      (loop
+       (let ((size (read-sequence block stream)))
+         (when (zerop size)
+           (return))
+         (unless (= size +block-size+)
+           (error "Bad size on tarfile"))
+         (when (every #'zerop block)
+           (return))
+         (let* ((payload-code (aref block 156))
+                (payload-type (payload-type payload-code))
+                (tar-path (or (shiftf extended-path nil)
+                              (full-path block)))
+                (full-path (merge-pathnames tar-path directory))
+                (payload-size (payload-size block))
+                (block-count (ceiling (payload-size block) +block-size+)))
+         (case payload-type
+           (:file
+            (save-file full-path payload-size stream))
+           (:directory
+            (ensure-directories-exist full-path))
+           ((:symlink :global-header)
+            ;; These block types aren't required for Quicklisp archives
+            (skip-n-blocks block-count stream))
+           (:long-name
+            (setf extended-path (gnu-long-name payload-size stream)))
+           (:pax-extended-header
+            (let* ((pax-header-data (read-octet-vector payload-size stream))
+                   (path (pax-header-path pax-header-data)))
+              (when path
+                (setf extended-path path))))
+           (t
+            (warn "Unknown tar block payload code -- ~D" payload-code)
+            (skip-n-blocks block-count stream)))))))))
+
+(defun contents (tarfile)
+  (let ((block (make-block-buffer))
+        (result '()))
+    (with-open-file (stream tarfile :element-type '(unsigned-byte 8))
+      (loop
+        (let ((size (read-sequence block stream)))
+          (when (zerop size)
+            (return (nreverse result)))
+          (unless (= size +block-size+)
+            (error "Bad size on tarfile"))
+          (when (every #'zerop block)
+            (return (nreverse result)))
+          (let* ((payload-type (payload-type (aref block 156)))
+                 (tar-path (full-path block))
+                 (payload-size (payload-size block)))
+            (skip-n-blocks (ceiling payload-size +block-size+) stream)
+            (case payload-type
+              (:file
+               (push tar-path result))
+              (:directory
+               (push tar-path result)))))))))

sbcl/.quicklisp/quicklisp/misc.lisp

@@ -0,0 +1,19 @@
+;;;; misc.lisp
+
+(in-package #:quicklisp-client)
+
+;;;
+;;; This stuff will probably end up somewhere else.
+;;;
+
+(defun use-only-quicklisp-systems ()
+  (asdf:initialize-source-registry
+   '(:source-registry :ignore-inherited-configuration))
+  (asdf:map-systems 'asdf:clear-system)
+  t)
+
+(defun who-depends-on (system-name)
+  "Return a list of names of systems that depend on SYSTEM-NAME."
+  (loop for system in (provided-systems t)
+        when (member system-name (required-systems system) :test 'string=)
+        collect (name system)))

sbcl/.quicklisp/quicklisp/network.lisp

@@ -0,0 +1,137 @@
+;;;
+;;; Low-level networking implementations
+;;;
+
+(in-package #:ql-network)
+
+(definterface host-address (host)
+  (:implementation t
+    host)
+  (:implementation sbcl
+    (ql-sbcl:host-ent-address (ql-sbcl:get-host-by-name host))))
+
+(definterface open-connection (host port)
+  (:documentation "Open and return a network connection to HOST on the
+  given PORT.")
+  (:implementation t
+    (declare (ignore host port))
+    (error "Sorry, quicklisp in implementation ~S is not supported yet."
+           (lisp-implementation-type)))
+  (:implementation allegro
+    (ql-allegro:make-socket :remote-host host
+                            :remote-port port))
+  (:implementation abcl
+    (let ((socket (ql-abcl:make-socket host port)))
+      (ql-abcl:get-socket-stream socket :element-type '(unsigned-byte 8))))
+  (:implementation ccl
+    (ql-ccl:make-socket :remote-host host
+                        :remote-port port))
+  (:implementation clasp
+    (let* ((endpoint (ql-clasp:host-ent-address
+                      (ql-clasp:get-host-by-name host)))
+           (socket (make-instance 'ql-clasp:inet-socket
+                                  :protocol :tcp
+                                  :type :stream)))
+      (ql-clasp:socket-connect socket endpoint port)
+      (ql-clasp:socket-make-stream socket
+                                 :element-type '(unsigned-byte 8)
+                                 :input t
+                                 :output t
+                                 :buffering :full)))
+  (:implementation clisp
+    (ql-clisp:socket-connect port host :element-type '(unsigned-byte 8)))
+  (:implementation cmucl
+    (let ((fd (ql-cmucl:connect-to-inet-socket host port)))
+      (ql-cmucl:make-fd-stream fd
+                               :element-type '(unsigned-byte 8)
+                               :binary-stream-p t
+                               :input t
+                               :output t)))
+  (:implementation scl
+    (let ((fd (ql-scl:connect-to-inet-socket host port)))
+      (ql-scl:make-fd-stream fd
+			     :element-type '(unsigned-byte 8)
+			     :input t
+			     :output t)))
+  (:implementation ecl
+    (let* ((endpoint (ql-ecl:host-ent-address
+                      (ql-ecl:get-host-by-name host)))
+           (socket (make-instance 'ql-ecl:inet-socket
+                                  :protocol :tcp
+                                  :type :stream)))
+      (ql-ecl:socket-connect socket endpoint port)
+      (ql-ecl:socket-make-stream socket
+                                 :element-type '(unsigned-byte 8)
+                                 :input t
+                                 :output t
+                                 :buffering :full)))
+  (:implementation mkcl
+    (let* ((endpoint (ql-mkcl:host-ent-address
+                      (ql-mkcl:get-host-by-name host)))
+           (socket (make-instance 'ql-mkcl:inet-socket
+                                  :protocol :tcp
+                                  :type :stream)))
+      (ql-mkcl:socket-connect socket endpoint port)
+      (ql-mkcl:socket-make-stream socket
+                                   :element-type '(unsigned-byte 8)
+                                   :input t
+                                   :output t
+                                   :buffering :full)))
+  (:implementation lispworks
+    (ql-lispworks:open-tcp-stream host port
+                                  :direction :io
+                                  :errorp t
+                                  :read-timeout nil
+                                  :element-type '(unsigned-byte 8)
+                                  :timeout 5))
+  (:implementation sbcl
+    (let* ((endpoint (ql-sbcl:host-ent-address
+                      (ql-sbcl:get-host-by-name host)))
+           (socket (make-instance 'ql-sbcl:inet-socket
+                                  :protocol :tcp
+                                  :type :stream)))
+      (ql-sbcl:socket-connect socket endpoint port)
+      (ql-sbcl:socket-make-stream socket
+                                  :element-type '(unsigned-byte 8)
+                                  :input t
+                                  :output t
+                                  :buffering :full))))
+
+(definterface read-octets (buffer connection)
+  (:documentation "Read from CONNECTION into BUFFER. Returns the
+  number of octets read.")
+  (:implementation t
+    (read-sequence buffer connection))
+  (:implementation allegro
+    (ql-allegro:read-vector buffer connection))
+  (:implementation clisp
+    (ql-clisp:read-byte-sequence buffer connection
+                                  :no-hang nil
+                                  :interactive t)))
+
+(definterface write-octets (buffer connection)
+  (:documentation "Write the contents of BUFFER to CONNECTION.")
+  (:implementation t
+    (write-sequence buffer connection)
+    (finish-output connection)))
+
+(definterface close-connection (connection)
+  (:implementation t
+    (ignore-errors (close connection))))
+
+(definterface call-with-connection (host port fun)
+  (:documentation "Establish a network connection to HOST on PORT and
+  call FUN with that connection as the only argument. Unconditionally
+  closes the connection afterwareds via CLOSE-CONNECTION in an
+  unwind-protect. See also WITH-CONNECTION.")
+  (:implementation t
+    (let (connection)
+      (unwind-protect
+           (progn
+             (setf connection (open-connection host port))
+             (funcall fun connection))
+        (when connection
+          (close-connection connection))))))
+
+(defmacro with-connection ((connection host port) &body body)
+  `(call-with-connection ,host ,port (lambda (,connection) ,@body)))

sbcl/.quicklisp/quicklisp/package.lisp

@@ -0,0 +1,340 @@
+;;;; package.lisp
+
+(defpackage #:ql-util
+  (:documentation
+   "Utility functions used in various places.")
+  (:use #:cl)
+  (:export #:write-line-to-file
+           #:without-prompting
+           #:press-enter-to-continue
+           #:replace-file
+           #:copy-file
+           #:delete-file-if-exists
+           #:ensure-file-exists
+           #:split-spaces
+           #:first-line
+           #:file-size
+           #:safely-read
+           #:safely-read-file
+           #:make-versions-url))
+
+(defpackage #:ql-setup
+  (:documentation
+   "Functions and variables initialized early in the Quicklisp client
+   configuration.")
+  (:use #:cl)
+  (:export #:qmerge
+           #:qenough
+           #:*quicklisp-home*))
+
+(defpackage #:ql-config
+  (:documentation
+   "Getting and setting persistent configuration values.")
+  (:use #:cl #:ql-util #:ql-setup)
+  (:export #:config-value))
+
+(defpackage #:ql-impl
+  (:documentation
+   "Configuration of implementation-specific packages and interfaces.")
+  (:use #:cl)
+  (:export #:*implementation*)
+  (:export #:definterface
+           #:defimplementation
+           #:show-interfaces)
+  (:export #:lisp
+           #:abcl
+           #:allegro
+           #:ccl
+           #:clasp
+           #:clisp
+           #:cmucl
+           #:cormanlisp
+           #:ecl
+           #:gcl
+           #:lispworks
+           #:mkcl
+           #:scl
+           #:sbcl))
+
+(defpackage #:ql-impl-util
+  (:documentation
+   "Utility functions that require implementation-specific
+   functionality.")
+  (:use #:cl #:ql-impl)
+  (:export #:call-with-quiet-compilation
+           #:add-to-init-file
+           #:rename-directory
+           #:delete-directory
+           #:probe-directory
+           #:directory-entries
+           #:delete-directory-tree
+           #:map-directory-tree
+           #:native-namestring
+           #:directory-write-date))
+
+(defpackage #:ql-network
+  (:documentation
+   "Simple, low-level network access.")
+  (:use #:cl #:ql-impl)
+  (:export #:open-connection
+           #:write-octets
+           #:read-octets
+           #:close-connection
+           #:with-connection))
+
+(defpackage #:ql-progress
+  (:documentation
+   "Displaying a progress bar.")
+  (:use #:cl)
+  (:export #:make-progress-bar
+           #:start-display
+           #:update-progress
+           #:finish-display))
+
+(defpackage #:ql-http
+  (:documentation
+   "A simple HTTP client.")
+  (:use #:cl #:ql-network #:ql-progress #:ql-config)
+  (:export #:*proxy-url*
+           #:fetch
+           #:http-fetch
+           #:*fetch-scheme-functions*
+           #:scheme
+           #:hostname
+           #:port
+           #:path
+           #:url
+           #:*maximum-redirects*
+           #:*default-url-defaults*)
+  (:export #:fetch-error
+           #:unexpected-http-status
+           #:unexpected-http-status-code
+           #:unexpected-http-status-url
+           #:too-many-redirects
+           #:too-many-redirects-url
+           #:too-many-redirects-count))
+
+(defpackage #:ql-minitar
+  (:documentation
+   "A simple implementation of unpacking the 'tar' file format.")
+  (:use #:cl)
+  (:export #:unpack-tarball))
+
+(defpackage #:ql-gunzipper
+  (:documentation
+   "An implementation of gunzip.")
+  (:use #:cl)
+  (:export #:gunzip))
+
+(defpackage #:ql-cdb
+  (:documentation
+   "Read and write CDB files; code adapted from ZCDB.")
+  (:use #:cl)
+  (:export #:lookup
+           #:map-cdb
+           #:convert-index-file))
+
+(defpackage #:ql-dist
+  (:documentation
+   "Generic functions, variables, and classes for interacting with the
+   dist system. Documented, exported symbols are intended for public
+   use.")
+  (:use #:cl
+        #:ql-util
+        #:ql-http
+        #:ql-setup
+        #:ql-gunzipper
+        #:ql-minitar)
+  (:intern #:dist-version
+           #:dist-url)
+  (:import-from #:ql-impl-util
+                #:delete-directory-tree
+                #:directory-entries
+                #:probe-directory)
+  ;; Install/enable protocol
+  (:export #:installedp
+           #:install
+           #:uninstall
+           #:ensure-installed
+           #:enabledp
+           #:enable
+           #:disable)
+  ;; Preference protocol
+  (:export #:preference
+           #:preference-file
+           #:preference-parent
+           #:forget-preference)
+  ;; Generic
+  (:export #:all-dists
+           #:canonical-distinfo-url
+           #:enabled-dists
+           #:find-dist
+           #:find-dist-or-lose
+           #:find-system
+           #:find-release
+           #:dist
+           #:system
+           #:release
+           #:base-directory
+           #:relative-to
+           #:metadata-name
+           #:install-metadata-file
+           #:short-description
+           #:provided-releases
+           #:provided-systems
+           #:installed-releases
+           #:installed-systems
+           #:name)
+  ;; Dists
+  (:export #:dist
+           #:dist-merge
+           #:find-system-in-dist
+           #:find-release-in-dist
+           #:system-index-url
+           #:release-index-url
+           #:available-versions-url
+           #:available-versions
+           #:version
+           #:subscription-url
+           #:new-version-available-p
+           #:dist-difference
+           #:fetch-dist
+           #:initialize-release-index
+           #:initialize-system-index
+           #:with-consistent-dists)
+  ;; Dist updates
+  (:export #:available-update
+           #:update-release-differences
+           #:show-update-report
+           #:update-in-place
+           #:install-dist
+           #:subscription-inhibition-file
+           #:inhibit-subscription
+           #:uninhibit-subscription
+           #:subscription-inhibited-p
+           #:subscription-unavailable
+           #:subscribedp
+           #:subscribe
+           #:unsubscribe)
+  ;; Releases
+  (:export #:release
+           #:project-name
+           #:system-files
+           #:archive-url
+           #:archive-size
+           #:ensure-archive-file
+           #:archive-content-sha1
+           #:archive-md5
+           #:prefix
+           #:local-archive-file
+           #:ensure-local-archive-file
+           #:check-local-archive-file
+           #:invalid-local-archive
+           #:invalid-local-archive-file
+           #:invalid-local-archive-release
+           #:missing-local-archive
+           #:badly-sized-local-archive
+           #:delete-and-retry)
+  ;; Systems
+  (:export #:dist
+           #:release
+           #:preference
+           #:system-file-name
+           #:required-systems)
+  ;; Misc
+  (:export #:standard-dist-enumeration-function
+           #:*dist-enumeration-functions*
+           #:find-asdf-system-file
+           #:system-definition-searcher
+           #:system-apropos
+           #:system-apropos-list
+           #:dependency-tree
+           #:clean
+           #:unknown-dist))
+
+(defpackage #:ql-dist-user
+  (:documentation
+   "A package that uses QL-DIST; useful for playing around in without
+   clobbering any QL-DIST internals.")
+  (:use #:cl
+        #:ql-dist))
+
+(defpackage #:ql-bundle
+  (:documentation
+   "A package for supporting the QL:BUNDLE-SYSTEMS function.")
+  (:use #:cl #:ql-dist #:ql-impl-util)
+  (:shadow #:find-system
+           #:find-release)
+  (:export #:bundle
+           #:requested-systems
+           #:ensure-system
+           #:ensure-release
+           #:write-bundle
+           #:add-systems-recursively
+           #:object-not-found
+           #:system-not-found
+           #:system-not-found-system
+           #:release-not-found
+           #:bundle-directory-exists
+           #:bundle-directory-exists-directory))
+
+(defpackage #:quicklisp-client
+  (:documentation
+   "The Quicklisp client package, intended for end-user Quicklisp
+   commands and configuration parameters.")
+  (:nicknames #:quicklisp #:ql)
+  (:use #:cl
+        #:ql-util
+        #:ql-impl-util
+        #:ql-dist
+        #:ql-http
+        #:ql-setup
+        #:ql-config
+        #:ql-minitar
+        #:ql-gunzipper)
+  (:shadow #:uninstall)
+  (:shadowing-import-from #:ql-dist
+                          #:dist-version
+                          #:dist-url)
+  (:export #:dist-version
+           #:dist-url)
+  (:export #:quickload
+           #:*quickload-prompt*
+           #:*quickload-verbose*
+           #:*quickload-explain*
+           #:system-not-found
+           #:system-not-found-name
+           #:uninstall
+           #:uninstall-dist
+           #:qmerge
+           #:*quicklisp-home*
+           #:*initial-dist-url*
+           #:*proxy-url*
+           #:config-value
+           #:setup
+           #:provided-systems
+           #:system-apropos
+           #:system-apropos-list
+           #:system-list
+           #:client-version
+           #:client-url
+           #:available-client-versions
+           #:install-client
+           #:update-client
+           #:update-dist
+           #:update-all-dists
+           #:available-dist-versions
+           #:add-to-init-file
+           #:use-only-quicklisp-systems
+           #:write-asdf-manifest-file
+           #:where-is-system
+           #:help
+           #:register-local-projects
+           #:local-projects-searcher
+           #:*local-project-directories*
+           #:list-local-projects
+           #:list-local-systems
+           #:who-depends-on
+           #:bundle-systems))
+
+(in-package #:quicklisp-client)

sbcl/.quicklisp/quicklisp/progress.lisp

@@ -0,0 +1,156 @@
+;;;
+;;; A text progress bar
+;;;
+
+(in-package #:ql-progress)
+
+(defclass progress-bar ()
+  ((start-time
+    :initarg :start-time
+    :accessor start-time)
+   (end-time
+    :initarg :end-time
+    :accessor end-time)
+   (progress-character
+    :initarg :progress-character
+    :accessor progress-character)
+   (character-count
+    :initarg :character-count
+    :accessor character-count
+    :documentation "How many characters wide is the progress bar?")
+   (characters-so-far
+    :initarg :characters-so-far
+    :accessor characters-so-far)
+   (update-interval
+    :initarg :update-interval
+    :accessor update-interval
+    :documentation "Update the progress bar display after this many
+    internal-time units.")
+   (last-update-time
+    :initarg :last-update-time
+    :accessor last-update-time
+    :documentation "The display was last updated at this time.")
+   (total
+    :initarg :total
+    :accessor total
+    :documentation "The total number of units tracked by this progress bar.")
+   (progress
+    :initarg :progress
+    :accessor progress
+    :documentation "How far in the progress are we?")
+   (pending
+    :initarg :pending
+    :accessor pending
+    :documentation "How many raw units should be tracked in the next
+    display update?"))
+  (:default-initargs
+   :progress-character #\=
+   :character-count 50
+   :characters-so-far 0
+   :update-interval (floor internal-time-units-per-second 4)
+   :last-update-time 0
+   :total 0
+   :progress 0
+   :pending 0))
+
+(defgeneric start-display (progress-bar))
+(defgeneric update-progress (progress-bar unit-count))
+(defgeneric update-display (progress-bar))
+(defgeneric finish-display (progress-bar))
+(defgeneric elapsed-time (progress-bar))
+(defgeneric units-per-second (progress-bar))
+
+(defmethod start-display (progress-bar)
+  (setf (last-update-time progress-bar) (get-internal-real-time))
+  (setf (start-time progress-bar) (get-internal-real-time))
+  (fresh-line)
+  (finish-output))
+
+(defmethod update-display (progress-bar)
+  (incf (progress progress-bar) (pending progress-bar))
+  (setf (pending progress-bar) 0)
+  (setf (last-update-time progress-bar) (get-internal-real-time))
+  (let* ((showable (floor (character-count progress-bar)
+                          (/ (total progress-bar) (progress progress-bar))))
+         (needed (- showable (characters-so-far progress-bar))))
+    (setf (characters-so-far progress-bar) showable)
+    (dotimes (i needed)
+      (write-char (progress-character progress-bar)))
+    (finish-output)))
+
+(defmethod update-progress (progress-bar unit-count)
+  (incf (pending progress-bar) unit-count)
+  (let ((now (get-internal-real-time)))
+    (when (< (update-interval progress-bar)
+             (- now (last-update-time progress-bar)))
+      (update-display progress-bar))))
+
+(defmethod finish-display (progress-bar)
+  (update-display progress-bar)
+  (setf (end-time progress-bar) (get-internal-real-time))
+  (terpri)
+  (format t "~:D bytes in ~$ seconds (~$KB/sec)~%"
+          (total progress-bar)
+          (elapsed-time progress-bar)
+          (/  (units-per-second progress-bar) 1024))
+  (finish-output))
+
+(defmethod elapsed-time (progress-bar)
+  (/ (- (end-time progress-bar) (start-time progress-bar))
+     internal-time-units-per-second))
+
+(defmethod units-per-second (progress-bar)
+  (if (plusp (elapsed-time progress-bar))
+      (/ (total progress-bar) (elapsed-time progress-bar))
+      0))
+
+(defun kb/sec (progress-bar)
+  (/ (units-per-second progress-bar) 1024))
+
+
+
+(defparameter *uncertain-progress-chars* "?")
+
+(defclass uncertain-size-progress-bar (progress-bar)
+  ((progress-char-index
+    :initarg :progress-char-index
+    :accessor progress-char-index)
+   (units-per-char
+    :initarg :units-per-char
+    :accessor units-per-char))
+  (:default-initargs
+   :total 0
+   :progress-char-index 0
+   :units-per-char (floor (expt 1024 2) 50)))
+
+(defmethod update-progress :after ((progress-bar uncertain-size-progress-bar)
+                            unit-count)
+  (incf (total progress-bar) unit-count))
+
+(defmethod progress-character ((progress-bar uncertain-size-progress-bar))
+  (let ((index (progress-char-index progress-bar)))
+    (prog1
+        (char *uncertain-progress-chars* index)
+      (setf (progress-char-index progress-bar)
+            (mod (1+ index) (length *uncertain-progress-chars*))))))
+
+(defmethod update-display ((progress-bar uncertain-size-progress-bar))
+  (setf (last-update-time progress-bar) (get-internal-real-time))
+  (multiple-value-bind (chars pend)
+      (floor (pending progress-bar) (units-per-char progress-bar))
+    (setf (pending progress-bar) pend)
+    (dotimes (i chars)
+      (write-char (progress-character progress-bar))
+      (incf (characters-so-far progress-bar))
+      (when (<= (character-count progress-bar)
+                (characters-so-far progress-bar))
+        (terpri)
+        (setf (characters-so-far progress-bar) 0)
+        (finish-output)))
+    (finish-output)))
+
+(defun make-progress-bar (total)
+  (if (or (not total) (zerop total))
+      (make-instance 'uncertain-size-progress-bar)
+      (make-instance 'progress-bar :total total)))
+

sbcl/.quicklisp/quicklisp/quicklisp.asd

@@ -0,0 +1,36 @@
+;;;; quicklisp.asd
+
+(defpackage #:ql-info
+  (:export #:*version*))
+
+(defvar ql-info:*version*
+  (with-open-file (stream (merge-pathnames "version.txt" *load-truename*))
+    (read-line stream)))
+
+(asdf:defsystem #:quicklisp
+  :description "The Quicklisp client application."
+  :author "Zach Beane <zach@quicklisp.org>"
+  :license "BSD-style"
+  :serial t
+  :version #.(remove-if-not #'digit-char-p ql-info:*version*)
+  :components ((:file "package")
+               (:file "utils")
+               (:file "config")
+               (:file "impl")
+               (:file "impl-util")
+               (:file "network")
+               (:file "progress")
+               (:file "http")
+               (:file "deflate")
+               (:file "minitar")
+               (:file "cdb")
+               (:file "dist")
+               (:file "setup")
+               (:file "client")
+               (:file "fetch-gzipped")
+               (:file "client-info")
+               (:file "client-update")
+               (:file "dist-update")
+               (:file "misc")
+               (:file "local-projects")
+               (:file "bundle")))

sbcl/.quicklisp/quicklisp/setup.lisp

@@ -0,0 +1,249 @@
+(in-package #:quicklisp)
+
+(defun show-wrapped-list (words &key (indent 4) (margin 60))
+ (let ((*print-right-margin* margin)
+       (*print-pretty* t)
+       (*print-escape* nil)
+       (prefix (make-string indent :initial-element #\Space)))
+   (pprint-logical-block (nil words :per-line-prefix prefix)
+     (pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil))
+   (fresh-line)
+   (finish-output)))
+
+(defun recursively-install (name)
+  (labels ((recurse (name)
+             (let ((system (find-system name)))
+               (unless system
+                 (error "Unknown system ~S" name))
+               (ensure-installed system)
+               (mapcar #'recurse (required-systems system))
+               name)))
+    (with-consistent-dists
+      (recurse name))))
+
+(defclass load-strategy ()
+  ((name
+    :initarg :name
+    :accessor name)
+   (asdf-systems
+    :initarg :asdf-systems
+    :accessor asdf-systems)
+   (quicklisp-systems
+    :initarg :quicklisp-systems
+    :accessor quicklisp-systems)))
+
+(defmethod print-object ((strategy load-strategy) stream)
+  (print-unreadable-object (strategy stream :type t)
+    (format stream "~S (~D asdf, ~D quicklisp)"
+            (name strategy)
+            (length (asdf-systems strategy))
+            (length (quicklisp-systems strategy)))))
+
+(defgeneric quicklisp-releases (strategy)
+  (:method (strategy)
+    (remove-duplicates (mapcar 'release (quicklisp-systems strategy)))))
+
+(defgeneric quicklisp-release-table (strategy)
+  (:method ((strategy load-strategy))
+    (let ((table (make-hash-table)))
+      (dolist (system (quicklisp-systems strategy))
+        (push system (gethash (release system) table nil)))
+      table)))
+
+(define-condition system-not-found (error)
+  ((name
+    :initarg :name
+    :reader system-not-found-name))
+  (:report (lambda (condition stream)
+             (format stream "System ~S not found"
+                     (system-not-found-name condition))))
+  (:documentation "This condition is signaled by QUICKLOAD when a
+  system given to load is not available via ASDF or a Quicklisp
+  dist."))
+
+(defun compute-load-strategy (name)
+  (setf name (string-downcase name))
+  (let ((asdf-systems '())
+        (quicklisp-systems '()))
+    (labels ((recurse (name)
+               (let ((asdf-system (asdf:find-system name nil))
+                     (quicklisp-system (find-system name)))
+                 (cond (asdf-system
+                        (push asdf-system asdf-systems))
+                       (quicklisp-system
+                        (push quicklisp-system quicklisp-systems)
+                        (dolist (subname (required-systems quicklisp-system))
+                          (recurse subname)))
+                       (t
+                        (cerror "Try again"
+                                'system-not-found
+                                :name name)
+                        (recurse name))))))
+      (with-consistent-dists
+        (recurse name)))
+    (make-instance 'load-strategy
+                   :name name
+                   :asdf-systems (remove-duplicates asdf-systems)
+                   :quicklisp-systems (remove-duplicates quicklisp-systems))))
+
+(defun show-load-strategy (strategy)
+  (format t "To load ~S:~%" (name strategy))
+  (let ((asdf-systems (asdf-systems strategy))
+        (releases (quicklisp-releases strategy)))
+    (when asdf-systems
+      (format t "  Load ~D ASDF system~:P:~%" (length asdf-systems))
+      (show-wrapped-list (mapcar 'asdf:component-name asdf-systems)))
+    (when releases
+      (format t "  Install ~D Quicklisp release~:P:~%" (length releases))
+      (show-wrapped-list (mapcar 'name releases)))))
+
+(defvar *macroexpand-progress-in-progress* nil)
+
+(defun macroexpand-progress-fun (old-hook &key (char #\.)
+                                 (chars-per-line 50)
+                                 (forms-per-char 250))
+  (let ((output-so-far 0)
+        (seen-so-far 0))
+    (labels ((finish-line ()
+               (when (plusp output-so-far)
+                 (dotimes (i (- chars-per-line output-so-far))
+                   (write-char char))
+                 (terpri)
+                 (setf output-so-far 0)))
+             (show-string (string)
+               (let* ((length (length string))
+                      (new-output (+ length output-so-far)))
+                 (cond ((< chars-per-line new-output)
+                        (finish-line)
+                        (write-string string)
+                        (setf output-so-far length))
+                       (t
+                        (write-string string)
+                        (setf output-so-far new-output))))
+               (finish-output))
+             (show-package (name)
+               ;; Only show package markers when compiling. Showing
+               ;; them when loading shows a bunch of ASDF system
+               ;; package noise.
+               (when *compile-file-pathname*
+                 (finish-line)
+                 (show-string (format nil "[package ~(~A~)]" name)))))
+      (lambda (fun form env)
+        (when (and (consp form)
+                   (eq (first form) 'cl:defpackage)
+                   (ignore-errors (string (second form))))
+          (show-package (second form)))
+        (incf seen-so-far)
+        (when (<= forms-per-char seen-so-far)
+          (setf seen-so-far 0)
+          (write-char char)
+          (finish-output)
+          (incf output-so-far)
+          (when (<= chars-per-line output-so-far)
+            (setf output-so-far 0)
+            (terpri)
+            (finish-output)))
+        (funcall old-hook fun form env)))))
+
+(defun call-with-macroexpand-progress (fun)
+  (let ((*macroexpand-hook* (if *macroexpand-progress-in-progress*
+                                *macroexpand-hook*
+                                (macroexpand-progress-fun *macroexpand-hook*)))
+        (*macroexpand-progress-in-progress* t))
+    (funcall fun)
+    (terpri)))
+
+(defun apply-load-strategy (strategy)
+  (map nil 'ensure-installed (quicklisp-releases strategy))
+  (call-with-macroexpand-progress
+   (lambda ()
+     (format t "~&; Loading ~S~%" (name strategy))
+     (asdf:load-system (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 ((tried-so-far (make-hash-table :test 'equalp)))
+      (tagbody
+       retry
+         (handler-case
+             (let ((strategy (compute-load-strategy name)))
+               (show-load-strategy strategy)
+               (when (or (not prompt)
+                         (press-enter-to-continue))
+                 (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
+                 ((or null asdf:system)
+                  ;; NIL parent comes from :defsystem-depends-on failures
+                  (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")
+
+(defun dists-initialized-p ()
+  (not (not (ignore-errors (truename (qmerge "dists/"))))))
+
+(defun quickstart-parameter (name &optional default)
+  (let* ((package (find-package '#:quicklisp-quickstart))
+         (symbol (and package (find-symbol (string '#:*quickstart-parameters*)
+                                           package)))
+         (plist (and symbol (symbol-value symbol)))
+         (parameter (and plist (getf plist name))))
+    (or parameter default)))
+
+(defun maybe-initial-setup ()
+  "Run the steps needed when Quicklisp setup is run for the first time
+after the quickstart installation."
+  (let ((quickstart-proxy-url (quickstart-parameter :proxy-url))
+        (quickstart-initial-dist-url (quickstart-parameter :initial-dist-url)))
+    (when (and quickstart-proxy-url (not *proxy-url*))
+      (setf *proxy-url* quickstart-proxy-url)
+      (setf (config-value "proxy-url") quickstart-proxy-url))
+    (unless (dists-initialized-p)
+      (let ((target (qmerge "dists/quicklisp/distinfo.txt"))
+            (url (or quickstart-initial-dist-url
+                     *initial-dist-url*)))
+        (ensure-directories-exist target)
+        (install-dist url :prompt nil)))))
+
+(defun setup ()
+  (unless (member 'system-definition-searcher
+                  asdf:*system-definition-search-functions*)
+    (setf asdf:*system-definition-search-functions*
+          (append asdf:*system-definition-search-functions*
+                  (list 'local-projects-searcher
+                        'system-definition-searcher))))
+  (let ((files (nconc (directory (qmerge "local-init/*.lisp"))
+                      (directory (qmerge "local-init/*.cl")))))
+    (with-simple-restart (abort "Stop loading local setup files")
+      (dolist (file (sort files #'string< :key #'pathname-name))
+        (with-simple-restart (skip "Skip local setup file ~S" file)
+          ;; Don't try to load Emacs lock files, other hidden files
+          (unless (char= (char (pathname-name file) 0)
+                         #\.)
+            (load file))))))
+  (maybe-initial-setup)
+  (ensure-directories-exist (qmerge "local-projects/"))
+  (pushnew :quicklisp *features*)
+  t)

sbcl/.quicklisp/quicklisp/utils.lisp

@@ -0,0 +1,124 @@
+;;;; utils.lisp
+
+(in-package #:ql-util)
+
+(defun write-line-to-file (string file)
+  (with-open-file (stream file
+                          :direction :output
+                          :if-exists :supersede)
+    (write-line string stream)))
+
+(defvar *do-not-prompt* nil
+  "When *DO-NOT-PROMPT* is true, PRESS-ENTER-TO-CONTINUE returns true
+  without user interaction.")
+
+(defmacro without-prompting (&body body)
+  "Evaluate BODY in an environment where PRESS-ENTER-TO-CONTINUE
+ always returns true without prompting for the user to press enter."
+  `(let ((*do-not-prompt* t))
+     ,@body))
+
+(defun press-enter-to-continue ()
+  (when *do-not-prompt*
+    (return-from press-enter-to-continue t))
+  (format *query-io* "~&Press Enter to continue.~%")
+  (let ((result (read-line *query-io*)))
+    (zerop (length result))))
+
+(defun replace-file (from to)
+  "Like RENAME-FILE, but deletes TO if it exists, first."
+  (when (probe-file to)
+    (delete-file to))
+  (rename-file from to))
+
+(defun copy-file (from to &key (if-exists :rename-and-delete))
+  "Copy the file FROM to TO."
+  (let* ((buffer-size 8192)
+         (buffer (make-array buffer-size :element-type '(unsigned-byte 8))))
+    (with-open-file (from-stream from :element-type '(unsigned-byte 8))
+      (with-open-file (to-stream to :element-type '(unsigned-byte 8)
+                                 :direction :output
+                                 :if-exists if-exists)
+        (let ((length (file-length from-stream)))
+          (multiple-value-bind (full leftover)
+              (floor length buffer-size)
+            (dotimes (i full)
+              (read-sequence buffer from-stream)
+              (write-sequence buffer to-stream))
+            (read-sequence buffer from-stream)
+            (write-sequence buffer to-stream :end leftover)))))
+    (probe-file to)))
+
+(defun ensure-file-exists (pathname)
+  (open pathname :direction :probe :if-does-not-exist :create))
+
+(defun delete-file-if-exists (pathname)
+  (when (probe-file pathname)
+    (delete-file pathname)))
+
+(defun split-spaces (line)
+  (let ((words '())
+        (mark 0)
+        (pos 0))
+    (labels ((finish ()
+               (setf pos (length line))
+               (save)
+               (return-from split-spaces (nreverse words)))
+             (save ()
+               (when (< mark pos)
+                 (push (subseq line mark pos) words)))
+             (mark ()
+               (setf mark pos))
+             (in-word (char)
+               (case char
+                 (#\Space
+                    (save)
+                    #'in-space)
+                 (t
+                    #'in-word)))
+             (in-space (char)
+               (case char
+                 (#\Space
+                    #'in-space)
+                 (t
+                    (mark)
+                    #'in-word))))
+      (let ((state #'in-word))
+        (dotimes (i (length line) (finish))
+          (setf pos i)
+          (setf state (funcall state (char line i))))))))
+
+(defun first-line (file)
+  (with-open-file (stream file)
+    (values (read-line stream))))
+
+(defun (setf first-line) (line file)
+  (with-open-file (stream file :direction :output
+                          :if-exists :rename-and-delete)
+    (write-line line stream)))
+
+(defun file-size (file)
+  (with-open-file (stream file :element-type '(unsigned-byte 8))
+    (file-length stream)))
+
+(defun safely-read (stream)
+  "Read one form from STREAM with *READ-EVAL* bound to NIL."
+  (let ((*read-eval* nil))
+    (read stream)))
+
+(defun safely-read-file (file)
+  "Read the first form from FILE with SAFELY-READ."
+  (with-open-file (stream file)
+    (safely-read stream)))
+
+(defun make-versions-url (url)
+  "Given an URL that looks like http://foo/bar.ext, return
+http://foo/bar-versions.txt."
+  (let ((suffix-pos (position #\. url :from-end t)))
+    (unless suffix-pos
+      (error "Can't make a versions URL from ~A" url))
+    (let ((extension (subseq url suffix-pos)))
+      (concatenate 'string
+                   (subseq url 0 suffix-pos)
+                   "-versions"
+                   extension))))

sbcl/.quicklisp/quicklisp/version.txt

@@ -0,0 +1 @@
+2020-01-04