Mercurial > hg > xemacs-beta

comparison lisp/prim/sort.el @ 72:b9518feda344 r20-0b31

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b31
author cvs
date Mon, 13 Aug 2007 09:03:46 +0200
parents 131b0175ea99
children c0c698873ce1
comparison
equal deleted inserted replaced
71:bae944334fa4 72:b9518feda344
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details. 19 ;; General Public License for more details.
20 20
21 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; see the file COPYING. If not, write to the 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
23 ;; Free Software Foundation, 59 Temple Place - Suite 330, 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
24 ;; Boston, MA 02111-1307, USA. 24 ;; 02111-1307, USA.
25 25
26 ;;; Synched up with: FSF 19.30. 26 ;;; Synched up with: FSF 19.34.
27 27
28 ;;; Commentary: 28 ;;; Commentary:
29 29
30 ;;; This package provides the sorting facilities documented in the XEmacs 30 ;;; This package provides the sorting facilities documented in the XEmacs
31 ;;; Reference Manual. 31 ;;; Reference Manual.
73 ;; Heuristically try to avoid messages if sorting a small amt of text. 73 ;; Heuristically try to avoid messages if sorting a small amt of text.
74 (let ((messages (> (- (point-max) (point-min)) 50000))) 74 (let ((messages (> (- (point-max) (point-min)) 50000)))
75 (save-excursion 75 (save-excursion
76 (if messages (message "Finding sort keys...")) 76 (if messages (message "Finding sort keys..."))
77 (let* ((sort-lists (sort-build-lists nextrecfun endrecfun 77 (let* ((sort-lists (sort-build-lists nextrecfun endrecfun
78 startkeyfun endkeyfun)) 78 startkeyfun endkeyfun))
79 (old (reverse sort-lists)) 79 (old (reverse sort-lists))
80 (case-fold-search sort-fold-case)) 80 (case-fold-search sort-fold-case))
81 (if (null sort-lists) 81 (if (null sort-lists)
82 () 82 ()
83 (or reverse (setq sort-lists (nreverse sort-lists))) 83 (or reverse (setq sort-lists (nreverse sort-lists)))
84 (if messages (message "Sorting records...")) 84 (if messages (message "Sorting records..."))
85 (setq sort-lists 85 (setq sort-lists
86 (if (fboundp 'sortcar) 86 (if (fboundp 'sortcar)
87 (sortcar sort-lists 87 (sortcar sort-lists
88 (cond ((numberp (car (car sort-lists))) 88 (cond ((numberp (car (car sort-lists)))
89 ;; This handles both ints and floats. 89 ;; This handles both ints and floats.
90 '<) 90 '<)
91 ((consp (car (car sort-lists))) 91 ((consp (car (car sort-lists)))
92 (function 92 (function
93 (lambda (a b) 93 (lambda (a b)
94 (> 0 (compare-buffer-substrings 94 (> 0 (compare-buffer-substrings
95 nil (car a) (cdr a) 95 nil (car a) (cdr a)
96 nil (car b) (cdr b)))))) 96 nil (car b) (cdr b))))))
97 (t 97 (t
98 'string<))) 98 'string<)))
99 (sort sort-lists 99 (sort sort-lists
100 (cond ((numberp (car (car sort-lists))) 100 (cond ((numberp (car (car sort-lists)))
101 'car-less-than-car) 101 'car-less-than-car)
102 ((consp (car (car sort-lists))) 102 ((consp (car (car sort-lists)))
103 (function (lambda (a b) 103 (function
104 (> 0 (compare-buffer-substrings 104 (lambda (a b)
105 nil (car (car a)) (cdr (car a)) 105 (> 0 (compare-buffer-substrings
106 nil (car (car b)) (cdr (car b))))))) 106 nil (car (car a)) (cdr (car a))
107 (t 107 nil (car (car b)) (cdr (car b)))))))
108 (function 108 (t
109 (lambda (a b) 109 (function
110 (string< (car a) (car b))))))))) 110 (lambda (a b)
111 (if reverse (setq sort-lists (nreverse sort-lists))) 111 (string< (car a) (car b)))))))))
112 (if messages (message "Reordering buffer...")) 112 (if reverse (setq sort-lists (nreverse sort-lists)))
113 (sort-reorder-buffer sort-lists old))) 113 (if messages (message "Reordering buffer..."))
114 (sort-reorder-buffer sort-lists old)))
114 (if messages (message "Reordering buffer... Done")))) 115 (if messages (message "Reordering buffer... Done"))))
115 nil) 116 nil)
116 117
117 ;; Parse buffer into records using the arguments as Lisp expressions; 118 ;; Parse buffer into records using the arguments as Lisp expressions;
118 ;; return a list of records. Each record looks like (KEY STARTPOS . ENDPOS) 119 ;; return a list of records. Each record looks like (KEY STARTPOS . ENDPOS)
137 ;; If key was not returned as value, 138 ;; If key was not returned as value,
138 ;; move to end of key and get key from the buffer. 139 ;; move to end of key and get key from the buffer.
139 (let ((start (point))) 140 (let ((start (point)))
140 (funcall (or endkeyfun 141 (funcall (or endkeyfun
141 (prog1 endrecfun (setq done t)))) 142 (prog1 endrecfun (setq done t))))
142 (cons start (point)))))) 143 (cons start (point))))))
143 ;; Move to end of this record (start of next one, or end of buffer). 144 ;; Move to end of this record (start of next one, or end of buffer).
144 (cond ((prog1 done (setq done nil))) 145 (cond ((prog1 done (setq done nil)))
145 (endrecfun (funcall endrecfun)) 146 (endrecfun (funcall endrecfun))
146 (nextrecfun (funcall nextrecfun) (setq done t))) 147 (nextrecfun (funcall nextrecfun) (setq done t)))
147 (if key (setq sort-lists (cons 148 (if key (setq sort-lists (cons
210 (save-excursion 211 (save-excursion
211 (save-restriction 212 (save-restriction
212 (narrow-to-region beg end) 213 (narrow-to-region beg end)
213 (goto-char (point-min)) 214 (goto-char (point-min))
214 (sort-subr reverse 215 (sort-subr reverse
215 (function (lambda () 216 (function
216 (while (and (not (eobp)) (looking-at paragraph-separate)) 217 (lambda ()
217 (forward-line 1)))) 218 (while (and (not (eobp)) (looking-at paragraph-separate))
219 (forward-line 1))))
218 'forward-paragraph)))) 220 'forward-paragraph))))
219 221
220 ;;;###autoload 222 ;;;###autoload
221 (defun sort-pages (reverse beg end) 223 (defun sort-pages (reverse beg end)
222 "Sort pages in region alphabetically; argument means descending order. 224 "Sort pages in region alphabetically; argument means descending order.
265 ;; (skip-chars-forward "[0-9]") 267 ;; (skip-chars-forward "[0-9]")
266 (forward-sexp 1) 268 (forward-sexp 1)
267 (point)))))) 269 (point))))))
268 nil)) 270 nil))
269 271
272 ;; This function is commented out of 19.34.
270 ;;;###autoload 273 ;;;###autoload
271 (defun sort-float-fields (field beg end) 274 (defun sort-float-fields (field beg end)
272 "Sort lines in region numerically by the ARGth field of each line. 275 "Sort lines in region numerically by the ARGth field of each line.
273 Fields are separated by whitespace and numbered from 1 up. Specified field 276 Fields are separated by whitespace and numbered from 1 up. Specified field
274 must contain a floating point number in each line of the region. With a 277 must contain a floating point number in each line of the region. With a
346 (save-excursion (beginning-of-line) (point)) 349 (save-excursion (beginning-of-line) (point))
347 (save-excursion (end-of-line) (point))))) 350 (save-excursion (end-of-line) (point)))))
348 ;; Position at the front of the field 351 ;; Position at the front of the field
349 ;; even if moving backwards. 352 ;; even if moving backwards.
350 (skip-chars-backward "^ \t\n"))) 353 (skip-chars-backward "^ \t\n")))
351
352 354
353 (defvar sort-regexp-fields-regexp) 355 (defvar sort-regexp-fields-regexp)
354 (defvar sort-regexp-record-end) 356 (defvar sort-regexp-record-end)
355 357
356 ;; Move to the beginning of the next match for record-regexp, 358 ;; Move to the beginning of the next match for record-regexp,
454 (forward-line) 456 (forward-line)
455 (setq end1 (point)) 457 (setq end1 (point))
456 (setq col-start (min col-beg1 col-end1)) 458 (setq col-start (min col-beg1 col-end1))
457 (setq col-end (max col-beg1 col-end1)) 459 (setq col-end (max col-beg1 col-end1))
458 (if (search-backward "\t" beg1 t) 460 (if (search-backward "\t" beg1 t)
459 (error 461 (error "sort-columns does not work with tabs. Use M-x untabify."))
460 "sort-columns does not work with tabs. Use M-x untabify."))
461 (if (not (eq system-type 'vax-vms)) 462 (if (not (eq system-type 'vax-vms))
462 ;; Use the sort utility if we can; it is 4 times as fast. 463 ;; Use the sort utility if we can; it is 4 times as fast.
463 (call-process-region beg1 end1 "sort" t t nil 464 (call-process-region beg1 end1 "sort" t t nil
464 (if reverse "-rt\n" "-t\n") 465 (if reverse "-rt\n" "-t\n")
466 ;; XEmacs (use int-to-string conversion)
465 (concat "+0." (int-to-string col-start)) 467 (concat "+0." (int-to-string col-start))
466 (concat "-0." (int-to-string col-end))) 468 (concat "-0." (int-to-string col-end)))
467 ;; On VMS, use Emacs's own facilities. 469 ;; On VMS, use Emacs's own facilities.
468 (save-excursion 470 (save-excursion
469 (save-restriction 471 (save-restriction