cl.el sort* efficiency

[Kevin Ryde]

I noticed that cl sort* function calls the given :key function within
every comparison, which is not good if key extraction is a big slow
calculation.  I struck such a case myself recently, and in fact the
example in the manual showing

        (sort* lst 'string-lessp :key 'downcase)

is almost another.  If possible I don't think you'd want to throw off
two new downcased strings in every compare.

The code below is an idea to build key results in an alist and sort
that.  It's not tested properly yet, and really isn't a thing of
beauty.  There's some trouble taken to rearrange the original cons
cells because that's discussed at length in the manual for plain
"sort", so maybe someone's relying on that.  Ideas for something
better or worse would be welcome.


(defun sort* (cl-seq cl-pred &rest cl-keys)
  "Sort the argument SEQ according to PREDICATE.
This is a destructive function; it reuses the storage of SEQ if possible.
\nKeywords supported:  :key
\n(fn SEQ PREDICATE [KEYWORD VALUE]...)"
  (if (nlistp cl-seq)
      (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys))
    (cl-parsing-keywords (:key) ()
      (if (memq cl-key '(nil identity))
          (sort cl-seq cl-pred)

        ;; turn cl-seq into an alist of (KEY-RESULT . ORIGINAL-CONS-CELL)
        (let (cl-x)
          (while cl-seq
            (setq cl-x (acons (funcall cl-key (car cl-seq)) cl-seq cl-x))
            (setq cl-seq (cdr cl-seq)))
          (setq cl-seq (nreverse cl-x)))
        ;; sort that alist by KEY-RESULT
        (setq cl-seq (sort cl-seq (if (eq cl-pred '<)
                                      'car-less-than-car
                                    (lambda (cl-x cl-y)
                                      (funcall cl-pred
                                               (car cl-x) (car cl-y))))))
        ;; mung cdrs of original cons cells to put them in new order
        (let (cell prev)
          (while cl-seq
            (setq cell (cdar cl-seq))
            (setcdr cell prev)
            (setq prev cell)
            (setq cl-seq (cdr cl-seq)))
          (nreverse prev))))))