Commits

Shlomi Fish  committed 1a101d9

Add the concat-uc function to test.

  • Participants
  • Parent commits df5b024

Comments (0)

Files changed (2)

File lurking-lisp-library/quicklisp.lisp

-;;;;
-;;;; This is quicklisp.lisp, the quickstart file for Quicklisp. To use
-;;;; it, start Lisp, then (load "quicklisp.lisp")
-;;;;
-;;;; Quicklisp is beta software and comes with no warranty of any kind.
-;;;;
-;;;; For more information about the Quicklisp beta, see:
-;;;;
-;;;;    http://www.quicklisp.org/beta/
-;;;;
-;;;; If you have any questions or comments about Quicklisp, please
-;;;; contact:
-;;;;
-;;;;    Zach Beane <zach@quicklisp.org>
-;;;;
-
-(cl:in-package #:cl-user)
-(cl:defpackage #:qlqs-user
-  (:use #:cl))
-(cl:in-package #:qlqs-user)
-
-(defpackage #:qlqs-impl
-  (:use #:cl)
-  (:export #:*implementation*)
-  (:export #:definterface
-           #:defimplementation)
-  (:export #:lisp
-           #:abcl
-           #:allegro
-           #:ccl
-           #:clisp
-           #:cmucl
-           #:cormanlisp
-           #:ecl
-           #:gcl
-           #:lispworks
-           #:scl
-           #:sbcl))
-
-(defpackage #:qlqs-impl-util
-  (:use #:cl #:qlqs-impl)
-  (:export #:call-with-quiet-compilation))
-
-(defpackage #:qlqs-network
-  (:use #:cl #:qlqs-impl)
-  (:export #:open-connection
-           #:write-octets
-           #:read-octets
-           #:close-connection
-           #:with-connection))
-
-(defpackage #:qlqs-progress
-  (:use #:cl)
-  (:export #:make-progress-bar
-           #:start-display
-           #:update-progress
-           #:finish-display))
-
-(defpackage #:qlqs-http
-  (:use #:cl #:qlqs-network #:qlqs-progress)
-  (:export #:fetch
-           #:*proxy-url*
-           #:*maximum-redirects*
-           #:*default-url-defaults*))
-
-(defpackage #:qlqs-minitar
-  (:use #:cl)
-  (:export #:tarball-contents
-           #:unpack-tarball))
-
-(defpackage #:quicklisp-quickstart
-  (:use #:cl #:qlqs-impl #:qlqs-impl-util #:qlqs-http #:qlqs-minitar)
-  (:export #:install
-           #:*proxy-url*
-           #:*asdf-url*
-           #:*quicklisp-tar-url*
-           #:*setup-url*
-           #:*after-load-message*
-           #:*after-initial-setup-message*))
-
-
-;;;
-;;; Defining implementation-specific packages and functionality
-;;;
-
-(in-package #:qlqs-impl)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun error-unimplemented (&rest args)
-    (declare (ignore args))
-    (error "Not implemented")))
-
-(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))))
-    `(eval-when (:compile-toplevel :load-toplevel :execute)
-       ,@(when effectivep
-               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* ((forbidden (intersection lambda-list lambda-list-keywords))
-         (gf-options (remove :implementation options :key #'first))
-         (implementations (set-difference options gf-options)))
-    (when forbidden
-      (error "~S not allowed in definterface lambda list" forbidden))
-    (flet ((method-option (class body)
-             `(:method ((*implementation* ,class) ,@lambda-list)
-                ,@body)))
-      (let ((generic-name (intern (format nil "%~A" name))))
-        `(eval-when (:compile-toplevel :load-toplevel :execute)
-           (defgeneric ,generic-name (lisp ,@lambda-list)
-             ,@gf-options
-             ,@(mapcar (lambda (implementation)
-                         (destructuring-bind (class &rest body)
-                             (rest implementation)
-                           (method-option class body)))
-                       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))))
-      (unless (and generic-name
-                   (fboundp generic-name))
-        (error "~S does not name an implementation function" name))
-      `(defmethod ,generic-name
-           ,@(when qualifier (list qualifier))
-         ,(list* `(*implementation* ,for) lambda-list) ,@body))))
-
-
-;;; Bootstrap implementations
-
-(defvar *implementation* nil)
-(defclass lisp () ())
-
-
-;;; Allegro Common Lisp
-
-(define-implementation-package :allegro #:qlqs-allegro
-  (:documentation
-   "Allegro Common Lisp - http://www.franz.com/products/allegrocl/")
-  (:class allegro)
-  (:reexport-from #:socket
-                  #:make-socket)
-  (:reexport-from #:excl
-                  #:read-vector))
-
-
-;;; Armed Bear Common Lisp
-
-(define-implementation-package :abcl #:qlqs-abcl
-  (:documentation
-   "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/")
-  (:class abcl)
-  (:reexport-from #:system
-                  #:make-socket
-                  #:get-socket-stream))
-
-;;; Clozure CL
-
-(define-implementation-package :ccl #:qlqs-ccl
-  (:documentation
-   "Clozure Common Lisp - http://www.clozure.com/clozurecl.html")
-  (:class ccl)
-  (:reexport-from #:ccl
-                  #:make-socket))
-
-;;; GNU CLISP
-
-(define-implementation-package :clisp #:qlqs-clisp
-  (:documentation "GNU CLISP - http://clisp.cons.org/")
-  (:class clisp)
-  (:reexport-from #:socket
-                  #:socket-connect)
-  (:reexport-from #:ext
-                  #:read-byte-sequence))
-
-
-;;; CMUCL
-
-(define-implementation-package :cmu #:qlqs-cmucl
-  (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/")
-  (:class cmucl)
-  (:reexport-from #:ext
-                  #:*gc-verbose*)
-  (:reexport-from #:system
-                  #:make-fd-stream)
-  (:reexport-from #:extensions
-                  #:connect-to-inet-socket))
-
-(defvar qlqs-cmucl:*gc-verbose* nil)
-
-
-;;; ECL
-
-(define-implementation-package :ecl #:qlqs-ecl
-  (:documentation "ECL - http://ecls.sourceforge.net/")
-  (:class ecl)
-  (:prep
-   (require 'sockets))
-  (:intern #:host-network-address)
-  (:reexport-from #:sb-bsd-sockets
-                  #:get-host-by-name
-                  #:host-ent-address
-                  #:socket-connect
-                  #:socket-make-stream
-                  #:inet-socket))
-
-
-;;; LispWorks
-
-(define-implementation-package :lispworks #:qlqs-lispworks
-  (:documentation "LispWorks - http://www.lispworks.com/")
-  (:class lispworks)
-  (:prep
-   (require "comm"))
-  (:reexport-from #:comm
-                  #:open-tcp-stream
-                  #:get-host-entry))
-
-
-;;; SBCL
-
-(define-implementation-package :sbcl #:qlqs-sbcl
-  (:class sbcl)
-  (:documentation
-   "Steel Bank Common Lisp - http://www.sbcl.org/")
-  (:prep
-   (require 'sb-bsd-sockets))
-  (:intern #:host-network-address)
-  (:reexport-from #:sb-ext
-                  #:compiler-note)
-  (:reexport-from #:sb-bsd-sockets
-                  #:get-host-by-name
-                  #:inet-socket
-                  #:host-ent-address
-                  #:socket-connect
-                  #:socket-make-stream))
-
-;;;
-;;; Utility function
-;;;
-
-(in-package #:qlqs-impl-util)
-
-(definterface call-with-quiet-compilation (fun)
-  (: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 (ignorable fun))
-  (handler-bind ((qlqs-sbcl:compiler-note #'muffle-warning))
-    (call-next-method)))
-
-(defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around)
-    (fun)
-  (declare (ignorable fun))
-  (let ((qlqs-cmucl:*gc-verbose* nil))
-    (call-next-method)))
-
-
-;;;
-;;; Low-level networking implementations
-;;;
-
-(in-package #:qlqs-network)
-
-(definterface host-address (host)
-  (:implementation t
-    host)
-  (:implementation sbcl
-    (qlqs-sbcl:host-ent-address (qlqs-sbcl:get-host-by-name host))))
-
-(definterface open-connection (host port)
-  (:implementation t
-    (declare (ignorable host port))
-    (error "Sorry, quicklisp in implementation ~S is not supported yet."
-           (lisp-implementation-type)))
-  (:implementation allegro
-    (qlqs-allegro:make-socket :remote-host host
-                             :remote-port port))
-  (:implementation abcl
-    (let ((socket (qlqs-abcl:make-socket host port)))
-      (qlqs-abcl:get-socket-stream socket :element-type '(unsigned-byte 8))))
-  (:implementation ccl
-    (qlqs-ccl:make-socket :remote-host host
-                         :remote-port port))
-  (:implementation clisp
-    (qlqs-clisp:socket-connect port host :element-type '(unsigned-byte 8)))
-  (:implementation cmucl
-    (let ((fd (qlqs-cmucl:connect-to-inet-socket host port)))
-      (qlqs-cmucl:make-fd-stream fd
-                                :element-type '(unsigned-byte 8)
-                                :binary-stream-p t
-                                :input t
-                                :output t)))
-  (:implementation ecl
-    (let* ((endpoint (qlqs-ecl:host-ent-address
-                      (qlqs-ecl:get-host-by-name host)))
-           (socket (make-instance 'qlqs-ecl:inet-socket
-                                  :protocol :tcp
-                                  :type :stream)))
-      (qlqs-ecl:socket-connect socket endpoint port)
-      (qlqs-ecl:socket-make-stream socket
-                                  :element-type '(unsigned-byte 8)
-                                  :input t
-                                  :output t
-                                  :buffering :full)))
-  (:implementation lispworks
-    (qlqs-lispworks:open-tcp-stream host port
-                                   :direction :io
-                                   :read-timeout nil
-                                   :element-type '(unsigned-byte 8)
-                                   :timeout 5))
-  (:implementation sbcl
-    (let* ((endpoint (qlqs-sbcl:host-ent-address
-                      (qlqs-sbcl:get-host-by-name host)))
-           (socket (make-instance 'qlqs-sbcl:inet-socket
-                                  :protocol :tcp
-                                  :type :stream)))
-      (qlqs-sbcl:socket-connect socket endpoint port)
-      (qlqs-sbcl:socket-make-stream socket
-                                   :element-type '(unsigned-byte 8)
-                                   :input t
-                                   :output t
-                                   :buffering :full))))
-
-(definterface read-octets (buffer connection)
-  (:implementation t
-    (read-sequence buffer connection))
-  (:implementation allegro
-    (qlqs-allegro:read-vector buffer connection))
-  (:implementation clisp
-    (qlqs-clisp:read-byte-sequence buffer connection
-                                  :no-hang nil
-                                  :interactive t)))
-
-(definterface write-octets (buffer 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)
-  (:implementation t
-    (let (connection)
-      (unwind-protect
-           (progn
-             (setf connection (open-connection host port))
-             (funcall fun connection))
-        (when connection
-          (close connection))))))
-
-(defmacro with-connection ((connection host port) &body body)
-  `(call-with-connection ,host ,port (lambda (,connection) ,@body)))
-
-
-;;;
-;;; A text progress bar
-;;;
-
-(in-package #:qlqs-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)))
-
-;;;
-;;; A simple HTTP client
-;;;
-
-(in-package #:qlqs-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* nil)
-
-(defun full-proxy-path (host port path)
-  (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A"
-                       (= port 443)
-                       host
-                       (or (= port 80)
-                           (= port 443))
-                       port
-                       path))
-
-(defun make-request-buffer (host port path &key (method "GET"))
-  (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 (= port 80) ""
-                                  (format nil ":~D" port)))
-      (add-line "Connection: close")
-      ;; FIXME: get this version string from somewhere else.
-      (add-line "User-Agent: quicklisp-bootstrap/2010113000")
-      (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))))
-             (pending-value (code)
-               (acase code
-                 ((#\Tab #\Space) #'pending-value)
-                 (:cr #'after-cr)
-                 (:lf #'in-new-line)
-                 (t (save pos value-starts) #'in-value)))
-             (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 ()
-  ((hostname
-    :initarg :hostname
-    :accessor hostname
-    :initform nil)
-   (port
-    :initarg :port
-    :accessor port
-    :initform 80)
-   (path
-    :initarg :path
-    :accessor path
-    :initform "/")))
-
-(defun parse-urlstring (urlstring)
-  (setf urlstring (string-trim " " urlstring))
-  (let* ((pos (mismatch urlstring "http://" :test 'char-equal))
-         (mark pos)
-         (url (make-instance 'url)))
-    (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) (port url) (path url)
-                         :method method)))
-
-(defun urlstring (url)
-  (format nil "~@[http://~A~]~@[:~D~]~A"
-          (hostname url)
-          (and (/= 80 (port 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
-                 :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)
-  (with-open-file (stream file
-                          :direction :output
-                          :if-exists :supersede
-                          :element-type 'octet)
-    (let ((content-length (content-length header)))
-      (cond (content-length
-             (call-for-n-octets content-length
-                                (make-stream-writer stream)
-                                cbuf))
-            ((chunkedp header)
-             (save-chunk-response 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)))
-
-(defun fetch (url file &key (follow-redirects t) quietly
-              (maximum-redirects *maximum-redirects*))
-  "Request URL and write the body of the response to FILE."
-  (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 for ~A" original-url))
-     (with-connection (connection (hostname connect-url) (port connect-url))
-       (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)
-                        (call-with-progress-bar (content-length header)
-                                                (lambda ()
-                                                  (save-response file header cbuf))))))
-                 ((not (<= 300 (status header) 399))
-                  (error "Unexpected status for ~A: ~A"
-                         url (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)))))))))))
-
-
-;;; A primitive tar unpacker
-
-(in-package #:qlqs-minitar)
-
-(defun make-block-buffer ()
-  (make-array 512 :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 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)
-    (53 :directory)
-    (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 512)
-    (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 unpack-tarball (tarfile &key (directory *default-pathname-defaults*))
-  (let ((block (make-block-buffer)))
-    (with-open-file (stream tarfile :element-type '(unsigned-byte 8))
-      (loop
-       (let ((size (read-sequence block stream)))
-         (when (zerop size)
-           (return))
-         (unless (= size 512)
-           (error "Bad size on tarfile"))
-         (when (every #'zerop block)
-           (return))
-         (let* ((payload-code (aref block 156))
-                (payload-type (payload-type payload-code))
-                (tar-path (full-path block))
-                (full-path (merge-pathnames tar-path directory))
-                (payload-size (payload-size block)))
-         (case payload-type
-           (:file
-            (save-file full-path payload-size stream))
-           (:directory
-            (ensure-directories-exist full-path))
-           (t
-            (warn "Unknown tar block payload code -- ~D" payload-code)
-            (skip-n-blocks (ceiling (payload-size block) 512) 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 512)
-            (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 512) stream)
-            (case payload-type
-              (:file
-               (push tar-path result))
-              (:directory
-               (push tar-path result)))))))))
-
-
-;;;
-;;; The actual bootstrapping work
-;;;
-
-(in-package #:quicklisp-quickstart)
-
-(defvar *home*
-  (merge-pathnames (make-pathname :directory '(:relative "quicklisp"))
-                   (user-homedir-pathname)))
-
-(defun qmerge (pathname)
-  (merge-pathnames pathname *home*))
-
-(defun renaming-fetch (url file)
-  (let ((tmpfile (qmerge "tmp/fetch.dat")))
-    (fetch url tmpfile)
-    (rename-file tmpfile file)))
-
-(defvar *asdf-url* "http://beta.quicklisp.org/quickstart/asdf.lisp")
-(defvar *quicklisp-tar-url* "http://beta.quicklisp.org/quickstart/quicklisp.tar")
-(defvar *setup-url* "http://beta.quicklisp.org/quickstart/setup.lisp")
-(defvar *after-load-message*
-  (format nil "~&~%  ==== quicklisp quickstart loaded ====~%~%    ~
-               To continue, evaluate: (quicklisp-quickstart:install)~%~%"))
-
-(defvar *after-initial-setup-message*
-  (with-output-to-string (*standard-output*)
-    (format t "~&~%  ==== quicklisp installed ====~%~%")
-    (format t "    To load a system, use: (ql:quickload \"system-name\")~%~%")
-    (format t "    To find systems, use: (ql:system-apropos \"term\")~%~%")
-    (format t "    To load Quicklisp every time you start Lisp, use: (ql:add-to-init-file)~%~%")
-    (format t "    For more information, see http://www.quicklisp.org/beta/~%~%")))
-
-(defun initial-install ()
-  (ensure-directories-exist (qmerge "tmp/"))
-  (ensure-directories-exist (qmerge "quicklisp/"))
-  (renaming-fetch *asdf-url* (qmerge "asdf.lisp"))
-  (let ((tmptar (qmerge "tmp/quicklisp.tar")))
-    (renaming-fetch *quicklisp-tar-url* tmptar)
-    (unpack-tarball tmptar :directory (qmerge "./")))
-  (renaming-fetch *setup-url* (qmerge "setup.lisp"))
-  (load (qmerge "setup.lisp"))
-  (write-string *after-initial-setup-message*)
-  (finish-output))
-
-(defun install (&key ((:path *home*) *home*)
-                ((:proxy *proxy-url*) *proxy-url*))
-  (setf *home* (merge-pathnames *home*))
-  (let ((setup-file (qmerge "setup.lisp")))
-    (when (probe-file setup-file)
-      (multiple-value-bind (result proceed)
-          (with-simple-restart (load-setup "Load ~S" setup-file)
-            (error "Quicklisp has already been installed. Load ~S instead."
-                   setup-file))
-        (declare (ignore result))
-        (when proceed
-          (return-from install (load setup-file))))))
-  (if (find-package '#:ql)
-      (progn
-        (write-line "!!! Quicklisp has already been set up. !!!")
-        (write-string *after-initial-setup-message*)
-        t)
-      (call-with-quiet-compilation #'initial-install)))
-
-;;; Try to canonicalize to an absolute pathname; helps on Lisps where
-;;; *default-pathname-defaults* isn't an absolute pathname at startup
-;;; (e.g. CCL, CMUCL)
-(setf *default-pathname-defaults* (truename *default-pathname-defaults*))
-
-(write-string *after-load-message*)
-
-;;; End of quicklisp.lisp

File lurking-lisp-library/t/op-equal-sign.lisp

 (use-package 'testbild)
 (load "lurking.lisp")
 
+(defun concat-uc (x y)
+  (concatenate 'string x (string-upcase y)))
+
 (let ((producer (make-instance 'tap-producer)))
   (init-test producer)
-  (emit-plan producer :plan-argument 2) ; simple plan, three tests planned
+  (emit-plan producer :plan-argument 3) ; simple plan, three tests planned
   (let ((result 28))
     (-= result 4)
     ; TEST
     (emit-result producer :success (= result 24) :description "Test -=")
     (*= result 2)
     ; TEST
-    (emit-result producer :success (= result 48) :description "Test *="))
+    (emit-result producer :success (= result 48) :description "Test *=")
+
+    ; TEST
+    (emit-result producer :success (equal (concat-uc "foo " "bar") "foo BAR")
+                 :description "Testing concat-uc")
+
+    )
   (finalize-test producer))