This one is from Vladimir Nesterovsky, an old contributor to the Autodesk Group:
;;; Mergesort.lsp
;;; free for non-commercial use only
;;; 1999 (C.) Vladimir Nesterovsky
;;; vnestr@netvision.net.il
;;; http://www.netvision.net.il/php/vnestr
;;; sort a list by standard mergesort method
;;; using a user-specified comparison function
;;; which should return true if and only if its
;;; first argument is strictly less than the
;;; second (in some appropriate sense).
;;; also, define a wrapper function that'll allow
;;; for sorting by user-supplied "value function",
;;; which is a function of one argument returning
;;; some "value" recognizable by the built-in '<
;;; operator. Sorting in this way can be much much
;;; faster then the usual way of calling the
;;; comparison function for each compare, because
;;; this potentially slow and heavy value-function
;;; gets called only ONCE for each element, and later
;;; all the compares are done with very fast and
;;; efficient built-in '< calls
;;; keeping original order of equal elements
;;; in the list (what's called "stable sort")
;;; uses recursion, so potentially unsafe
;;; more code is inlined to speed up the end cases
;;; handling, like 2-, 3- or 4-elements lists,
;;; also reducing the amount of recursion,
;;; which amounts to some 45% speed gain
(defun mergesort (lst less-then?)
;; is it the fastest autolisp version?
(setq less-then? (make-usubr less-then?))
(_mrgsrt lst))
(defun make-usubr (f)
(cond
((and (not (atom f))
(not (equal 'LAMBDA (car f))))
(eval (cons 'LAMBDA f)))
((eval f))))
(defun _mrgsrt (ls / len a b c d l1)
(cond
((< (setq len (length ls)) 2)
;; one-element or empty list
ls)
((= len 2)
;; 26% speed gain for 10-elems list, 18% for 250
;; when this special case inlined
(if (less-then? (cadr ls) (car ls))
(reverse ls)
ls))
((= len 3)
;; more 10% speed gain
(if (less-then? (cadr ls) (car ls))
(cond
((less-then? (caddr ls) (cadr ls))
(reverse ls))
((less-then? (caddr ls) (car ls))
(list (cadr ls) (caddr ls) (car ls)))
((list (cadr ls) (car ls) (caddr ls))))
(cond
((less-then? (caddr ls) (car ls))
(list (caddr ls) (car ls) (cadr ls)))
((less-then? (caddr ls) (cadr ls))
(list (car ls) (caddr ls) (cadr ls)))
( ls ))))
((= len 4)
;; another 15% speed gain for 4*2^n initial lengths
;; (no impact on 3*2^n cases)
(if (less-then? (cadr ls) (car ls))
(setq a (cadr ls) b (car ls))
(setq b (cadr ls) a (car ls)))
(if (less-then? (last ls) (caddr ls))
(setq c (last ls) d (caddr ls))
(setq d (last ls) c (caddr ls)))
(cond
((less-then? d a)
(list c d a b))
((less-then? d b)
(if (less-then? c a)
(list c a d b)
(list a c d b)))
((cond
((less-then? c a)
(list c a b d))
((less-then? c b)
(list a c b d))
((list a b c d))))))
( t
;; general case
(repeat (/ len 2)
(setq l1 (cons (car ls) l1)
ls (cdr ls)))
(_mrgsrt-merge
(_mrgsrt (reverse l1))
(_mrgsrt ls)))))
;;; merge two sorted lists in a stable manner
;;; less-then? usubr assumed to be defined globally
;;; may be used independently when needed
(defun _mrgsrt-merge (l1 l2 / rslt)
(while (and l1 l2) ;merge the sorted halves back
(while (and l1 l2
(not (less-then? (car l2) (car l1))))
(setq rslt (cons (car l1) rslt)
l1 (cdr l1)))
(while (and l1 l2
(less-then? (car l2) (car l1)))
(setq rslt (cons (car l2) rslt)
l2 (cdr l2))) )
(foreach e l1 (Setq rslt (cons e rslt)))
(foreach e l2 (Setq rslt (cons e rslt)))
(reverse rslt))
;;; sort by Value function
;;; (it's generally much faster then sorting
;;; by compare-function because potentially
;;; slow value-function will be called only
;;; once for each element here)
;;; Value function is such that excepts one
;;; argument and returns an atomic value
;;; for which calling '< is meaningful
;;; (numbers usually, but may be strings too).
(defun Vmergesort (lst valfun)
(setq valfun (make-usubr valfun))
(mapcar 'cdr
(mergesort
(mapcar '(lambda (e) ;calculate results
(cons (valfun e) e)) ; in advance
lst) ;store them and
car-less?))) ;sort by comparing CARs
(defun car-less? (a b)
(< (car a) (car b)))
;;; one possible efficiency improvement can be
;;; to implement a special version of vmergesort
;;; hand-coded to sort its argument list elements
;;; by their CARs and also automatically strip them
;;; away with CDRs while merging half-lists back
(princ "\n Usage: (MERGESORT list compare-function) ")
(princ "\n Or better: (VMERGESORT list value-function)")
(princ)