#!/usr/local/bin/sbcl --script
(defun permutations (list callback)
  (when list
    (let* ((all (cons 'head (copy-list list)))           ; head sentinel FTW!
           (perm (make-array (length list))))
      (labels ((g (p i &optional (q (cdr p)))
                (cond
                  ((null (cdr q))  
                     (setf (svref perm i) (car q))       ; the last item
                     (funcall callback perm))
                  ((null (cddr q))  
                     (setf (svref perm i) (car q))       ; the last two items
                     (setf (svref perm (+ i 1)) (cadr q))  
                     (funcall callback perm)
                     (setf (svref perm i) (cadr q))    
                     (setf (svref perm (+ i 1)) (car q))  
                     (funcall callback perm))
                  (T (loop while q do
                        (setf (svref perm i) (car q))    ; pick the item
                        (rplacd p (cdr q))               ; shrink the domain
                        (g all (+ 1 i))                  ; recurse!
                        (rplacd p q)                     ; heal the list back
                        (pop p)  
                        (pop q))))))                     ; advance the pointers
        (g all 0)))))
 
(time (let ((c 0))
  (permutations '(1 2 3) #'(lambda(p)(format t "~A " p)))      ; incf c
  (print c)))