2006-02-19 Michael Kifer <kifer@cs.stonybrook.edu>

[gnu-emacs] / lisp / sort.el

diff --git a/lisp/sort.el b/lisp/sort.el
index 33f523c9533a291791db729f05d1ecc870ed0618..174a8531786a8b00c7f75c88ae69f929c433d979 100644 (file)
--- a/lisp/sort.el
+++ b/lisp/sort.el
@@ -1,6 +1,7 @@
-;;; sort.el --- commands to sort text in an Emacs buffer.
+;;; sort.el --- commands to sort text in an Emacs buffer

 
 

-;; Copyright (C) 1986, 1987, 1994, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1987, 1994, 1995, 2002, 2003,
+;;   2004, 2005, 2006 Free Software Foundation, Inc.

 
 ;; Author: Howie Kaye
 ;; Maintainer: FSF
 
 ;; Author: Howie Kaye
 ;; Maintainer: FSF


@@ -20,8 +21,8 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the

-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -40,9 +41,9 @@
   :type 'boolean)
 
 ;;;###autoload
   :type 'boolean)
 
 ;;;###autoload

-(defun sort-subr (reverse nextrecfun endrecfun &optional startkeyfun endkeyfun)
+(defun sort-subr (reverse nextrecfun endrecfun
+                         &optional startkeyfun endkeyfun predicate)

   "General text sorting routine to divide buffer into records and sort them.
   "General text sorting routine to divide buffer into records and sort them.

-Arguments are REVERSE NEXTRECFUN ENDRECFUN &optional STARTKEYFUN ENDKEYFUN.

 
 We divide the accessible portion of the buffer into disjoint pieces
 called sort records.  A portion of each sort record (perhaps all of
 
 We divide the accessible portion of the buffer into disjoint pieces
 called sort records.  A portion of each sort record (perhaps all of


@@ -75,7 +76,10 @@ starts at the beginning of the record.
 
 ENDKEYFUN moves from the start of the sort key to the end of the sort key.
 ENDKEYFUN may be nil if STARTKEYFUN returns a value or if it would be the
 
 ENDKEYFUN moves from the start of the sort key to the end of the sort key.
 ENDKEYFUN may be nil if STARTKEYFUN returns a value or if it would be the

-same as ENDRECFUN."
+same as ENDRECFUN.
+
+PREDICATE is the function to use to compare keys.  If keys are numbers,
+it defaults to `<', otherwise it defaults to `string<'."

   ;; Heuristically try to avoid messages if sorting a small amt of text.
   (let ((messages (> (- (point-max) (point-min)) 50000)))
     (save-excursion
   ;; Heuristically try to avoid messages if sorting a small amt of text.
   (let ((messages (> (- (point-max) (point-min)) 50000)))
     (save-excursion


@@ -89,32 +93,18 @@ same as ENDRECFUN."
          (or reverse (setq sort-lists (nreverse sort-lists)))
          (if messages (message "Sorting records..."))
          (setq sort-lists
          (or reverse (setq sort-lists (nreverse sort-lists)))
          (if messages (message "Sorting records..."))
          (setq sort-lists

-               (if (fboundp 'sortcar)
-                   (sortcar sort-lists
-                            (cond ((numberp (car (car sort-lists)))
-                                   ;; This handles both ints and floats.
-                                   '<)
-                                  ((consp (car (car sort-lists)))
-                                   (function
-                                    (lambda (a b)
-                                      (> 0 (compare-buffer-substrings 
-                                            nil (car a) (cdr a)
-                                            nil (car b) (cdr b))))))
-                                  (t
-                                   'string<)))
-                 (sort sort-lists
-                       (cond ((numberp (car (car sort-lists)))
-                              'car-less-than-car)
-                             ((consp (car (car sort-lists)))
-                              (function
-                               (lambda (a b)
-                                 (> 0 (compare-buffer-substrings 
-                                       nil (car (car a)) (cdr (car a))
-                                       nil (car (car b)) (cdr (car b)))))))
-                             (t
-                              (function
-                               (lambda (a b)
-                                 (string< (car a) (car b)))))))))
+               (sort sort-lists
+                     (cond (predicate
+                            `(lambda (a b) (,predicate (car a) (car b))))
+                           ((numberp (car (car sort-lists)))
+                            'car-less-than-car)
+                           ((consp (car (car sort-lists)))
+                            (lambda (a b)
+                              (> 0 (compare-buffer-substrings
+                                    nil (car (car a)) (cdr (car a))
+                                    nil (car (car b)) (cdr (car b))))))
+                           (t
+                            (lambda (a b) (string< (car a) (car b)))))))

          (if reverse (setq sort-lists (nreverse sort-lists)))
          (if messages (message "Reordering buffer..."))
          (sort-reorder-buffer sort-lists old)))
          (if reverse (setq sort-lists (nreverse sort-lists)))
          (if messages (message "Reordering buffer..."))
          (sort-reorder-buffer sort-lists old)))


@@ -151,53 +141,57 @@ same as ENDRECFUN."
       (cond ((prog1 done (setq done nil)))
            (endrecfun (funcall endrecfun))
            (nextrecfun (funcall nextrecfun) (setq done t)))
       (cond ((prog1 done (setq done nil)))
            (endrecfun (funcall endrecfun))
            (nextrecfun (funcall nextrecfun) (setq done t)))

-      (if key (setq sort-lists (cons
-                                ;; consing optimization in case in which key
-                                ;; is same as record.
-                                (if (and (consp key)
-                                         (equal (car key) start-rec)
-                                         (equal (cdr key) (point)))
-                                    (cons key key)
-                                  (cons key (cons start-rec (point))))
-                                sort-lists)))
+      (if key (push
+              ;; consing optimization in case in which key is same as record.
+              (if (and (consp key)
+                       (equal (car key) start-rec)
+                       (equal (cdr key) (point)))
+                  (cons key key)
+                (cons key (cons start-rec (point))))
+              sort-lists))

       (and (not done) nextrecfun (funcall nextrecfun)))
     sort-lists))
 
 (defun sort-reorder-buffer (sort-lists old)
       (and (not done) nextrecfun (funcall nextrecfun)))
     sort-lists))
 
 (defun sort-reorder-buffer (sort-lists old)

-  (let ((inhibit-quit t)
-       (last (point-min))
-       (min (point-min)) (max (point-max)))
-    ;; Make sure insertions done for reordering
-    ;; do not go after any markers at the end of the sorted region,
-    ;; by inserting a space to separate them.
-    (goto-char (point-max))
-    (insert-before-markers " ")
-    (narrow-to-region min (1- (point-max)))
-    (while sort-lists
-      (goto-char (point-max))
-      (insert-buffer-substring (current-buffer)
-                              last
-                              (nth 1 (car old)))
+  (let ((last (point-min))
+       (min (point-min)) (max (point-max))
+       (old-buffer (current-buffer))
+       temp-buffer)
+    (with-temp-buffer
+      ;; Record the temporary buffer.
+      (setq temp-buffer (current-buffer))
+
+      ;; Copy the sorted text into the temporary buffer.
+      (while sort-lists
+       (goto-char (point-max))
+       (insert-buffer-substring old-buffer
+                                last
+                                (nth 1 (car old)))
+       (goto-char (point-max))
+       (insert-buffer-substring old-buffer
+                                (nth 1 (car sort-lists))
+                                (cdr (cdr (car sort-lists))))
+       (setq last (cdr (cdr (car old)))
+             sort-lists (cdr sort-lists)
+             old (cdr old)))

       (goto-char (point-max))
       (goto-char (point-max))

-      (insert-buffer-substring (current-buffer)
-                              (nth 1 (car sort-lists))
-                              (cdr (cdr (car sort-lists))))
-      (setq last (cdr (cdr (car old)))
-           sort-lists (cdr sort-lists)
-           old (cdr old)))
-    (goto-char (point-max))
-    (insert-buffer-substring (current-buffer)
-                            last
-                            max)
-    ;; Delete the original copy of the text.
-    (delete-region min max)
-    ;; Get rid of the separator " ".
-    (goto-char (point-max))
-    (narrow-to-region min (1+ (point)))
-    (delete-region (point) (1+ (point)))))
+      (insert-buffer-substring old-buffer last max)
+
+      ;; Copy the reordered text from the temporary buffer
+      ;; to the buffer we sorted (OLD-BUFFER).
+      (set-buffer old-buffer)
+      (let ((inhibit-quit t))
+       ;; Make sure insertions done for reordering
+       ;; saves any markers at the end of the sorted region,
+       ;; by leaving the last character of the region.
+       (delete-region min (1- max))
+       ;; Now replace the one remaining old character with the sorted text.
+       (goto-char (point-min))
+       (insert-buffer-substring temp-buffer)
+       (delete-region max (1+ max))))))

 
 ;;;###autoload
 
 ;;;###autoload

-(defun sort-lines (reverse beg end) 
+(defun sort-lines (reverse beg end)

   "Sort lines in region alphabetically; argument means descending order.
 Called from a program, there are three arguments:
 REVERSE (non-nil means reverse order), BEG and END (region to sort).
   "Sort lines in region alphabetically; argument means descending order.
 Called from a program, there are three arguments:
 REVERSE (non-nil means reverse order), BEG and END (region to sort).


@@ -421,7 +415,7 @@ For example: to sort lines in the region by the first word on each line
   ;; using negative prefix arg to mean "reverse" is now inconsistent with
   ;; other sort-.*fields functions but then again this was before, since it
   ;; didn't use the magnitude of the arg to specify anything.
   ;; using negative prefix arg to mean "reverse" is now inconsistent with
   ;; other sort-.*fields functions but then again this was before, since it
   ;; didn't use the magnitude of the arg to specify anything.

-  (interactive "P\nsRegexp specifying records to sort: 
+  (interactive "P\nsRegexp specifying records to sort:

 sRegexp specifying key within record: \nr")
   (cond ((or (equal key-regexp "") (equal key-regexp "\\&"))
         (setq key-regexp 0))
 sRegexp specifying key within record: \nr")
   (cond ((or (equal key-regexp "") (equal key-regexp "\\&"))
         (setq key-regexp 0))


@@ -433,7 +427,7 @@ sRegexp specifying key within record: \nr")
       (goto-char (point-min))
       (let (sort-regexp-record-end
            (sort-regexp-fields-regexp record-regexp))
       (goto-char (point-min))
       (let (sort-regexp-record-end
            (sort-regexp-fields-regexp record-regexp))

-       (re-search-forward sort-regexp-fields-regexp)
+       (re-search-forward sort-regexp-fields-regexp nil t)

        (setq sort-regexp-record-end (point))
        (goto-char (match-beginning 0))
        (sort-subr reverse
        (setq sort-regexp-record-end (point))
        (goto-char (match-beginning 0))
        (sort-subr reverse


@@ -487,19 +481,30 @@ Use \\[untabify] to convert tabs to spaces before sorting."
       (setq col-end (max col-beg1 col-end1))
       (if (search-backward "\t" beg1 t)
          (error "sort-columns does not work with tabs -- use M-x untabify"))
       (setq col-end (max col-beg1 col-end1))
       (if (search-backward "\t" beg1 t)
          (error "sort-columns does not work with tabs -- use M-x untabify"))

-      (if (not (or (eq system-type 'vax-vms)
-                  (text-properties-at beg1)
-                  (< (next-property-change beg1 nil end1) end1)))
+      (if (not (or (memq system-type '(vax-vms windows-nt))
+                  (let ((pos beg1) plist fontified)
+                    (catch 'found
+                      (while (< pos end1)
+                        (setq plist (text-properties-at pos))
+                        (setq fontified (plist-get plist 'fontified))
+                        (while (consp plist)
+                          (unless (or (eq (car plist) 'fontified)
+                                      (and (eq (car plist) 'face)
+                                           fontified))
+                            (throw 'found t))
+                          (setq plist (cddr plist)))
+                        (setq pos (next-property-change pos nil end1)))))))

          ;; Use the sort utility if we can; it is 4 times as fast.
          ;; Use the sort utility if we can; it is 4 times as fast.

-         ;; Do not use it if there are any properties in the region,
-         ;; since the sort utility would lose the properties.
+         ;; Do not use it if there are any non-font-lock properties
+         ;; in the region, since the sort utility would lose the
+         ;; properties.

          (let ((sort-args (list (if reverse "-rt\n" "-t\n")
                                 (concat "+0." (int-to-string col-start))
                                 (concat "-0." (int-to-string col-end)))))
            (when sort-fold-case
              (push "-f" sort-args))
            (apply #'call-process-region beg1 end1 "sort" t t nil sort-args))
          (let ((sort-args (list (if reverse "-rt\n" "-t\n")
                                 (concat "+0." (int-to-string col-start))
                                 (concat "-0." (int-to-string col-end)))))
            (when sort-fold-case
              (push "-f" sort-args))
            (apply #'call-process-region beg1 end1 "sort" t t nil sort-args))

-       ;; On VMS, use Emacs's own facilities.
+       ;; On VMS and ms-windows, use Emacs's own facilities.

        (save-excursion
          (save-restriction
            (narrow-to-region beg1 end1)
        (save-excursion
          (save-restriction
            (narrow-to-region beg1 end1)


@@ -542,4 +547,5 @@ From a program takes two point or marker arguments, BEG and END."
 
 (provide 'sort)
 
 
 (provide 'sort)
 

+;;; arch-tag: fbac12be-2a7b-4c8a-9665-264d61f70bd9

 ;;; sort.el ends here
 ;;; sort.el ends here