A fast MAPCONCAT implementation in Common Lisp

Here’s an implementation of Emacs Lisp’s MAPCONCAT function for Common Lisp.

(defun mapconcat (fun list sep)
   (when list
      (let ((~sep (with-output-to-string (*standard-output*)
                     (map nil (lambda (ch) (princ (if (char= #~ ch) "~~" ch))) sep))))
       (format nil (format nil "~~A~~{~A~~A~~}" ~sep)
               (funcall fun (first list))
               (mapcar fun (rest list))))))

timed :

* (time (mapconcat 'identity *mylist* "-"))
 Evaluation took:
   2.805 seconds of real time
   2.746358 seconds of total run time (2.736834 user, 0.009524 system)
   [ Run times consist of 0.004 seconds GC time, and 2.743 seconds
     non-GC time. ]
   97.90% CPU
   6,324,642,149 processor cycles
   17,734,520 bytes consed
 "0-1-2-3-4-5-6-7-8-9-10- ... "

And here’s an optimized version.

(setf *mylist*
      (let ((l (list 0)))
        (dotimes (i 10000 i) (nconc l (list (write-to-string i))))
        (cdr l)))
(defun mapconcat(func lst sep)
  (let ((vs (make-array 0
                        :element-type 'character
                        :fill-pointer 0
                        :adjustable t)))
    (dotimes (i (length lst) i)
      (let ((str (funcall func (nth i lst))))
        (dotimes (j (length str) j)
          (vector-push-extend (char str j) vs))
        (dotimes (k (length sep) k)
          (vector-push-extend (char sep k) vs))))
    vs))

timed :

* (time (mapconcat 'identity *mylist* "-"))
 Evaluation took:
   0.133 seconds of real time
   0.098758 seconds of total run time (0.098390 user, 0.000368 system)
   74.44% CPU
   299,046,898 processor cycles
   517,800 bytes consed
 "0-1-2-3-4-5-6-7-8-9-10- ... "

As someone pointed out the following would be much faster using FORMAT’s powerful directives and turning off *pretty-print* :

(defun mapconcat (function list elem)
  (let (*print-pretty*)
    (format nil (format nil "~~{~~a~~^~a~~}" elem)
            (mapcar function list))))

timed :

* (time (mapconcat 'identity *mylist* "-"))
Evaluation took:
  0.006 seconds of real time
  0.005033 seconds of total run time (0.005001 user, 0.000032 system)
  83.33% CPU
  11,430,579 processor cycles
  539,200 bytes consed
 "0-1-2-3-4-5-6-7-8-9-10- ... "

However, the FORMAT version does not demonstrate a fast CL implementation.
To get the low-level implementation to match the performance of the FORMAT implementation we simply make a few tweaks.
(We replace DOTIMES/NTH for the outer loop with MAPCAR as NTH is slow).

(defun mapconcat(func lst sep)
  (declare (type (cons (simple-array character (*))) lst))
  (declare (type (simple-array character (*)) sep))
  (let ((vs (make-array 0
                        :element-type 'character
                        :fill-pointer 0
                        :adjustable t))
        (lsep (length sep)))
    (mapcar #'(lambda (str)
                (let ((nstr (funcall func str)))
                  (declare (type (simple-array character (*)) nstr))
                  (dotimes (j (length nstr) j)
                    (declare (type fixnum j))
                    (vector-push-extend (char nstr j) vs))
                  (dotimes (k lsep k)
                    (declare (type fixnum k))
                    (vector-push-extend (char sep k) vs))))
                lst)
    vs))

timed :

* (time (mapconcat 'identity *mylist* "-"))
Evaluation took:
  0.006 seconds of real time
  0.005435 seconds of total run time (0.005261 user, 0.000174 system)
  83.33% CPU
  11,845,515 processor cycles
  605,792 bytes consed
 "0-1-2-3-4-5-6-7-8-9-10- ... "

(all versions timed on SBCL 1.0.29, OS X 10.5.7, 2.26 GHz core 2 duo macbook)