Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-sort.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 441bb1e64a06
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; Sorting and moving messages inside VM
2 ;;; Copyright (C) 1993, 1994 Kyle E. Jones
3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program; if not, write to the Free Software
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
17
18 (provide 'vm-sort)
19
20 (defun vm-move-message-forward (count)
21 "Move a message forward in a VM folder.
22 Prefix arg COUNT causes the current message to be moved COUNT messages forward.
23 A negative COUNT causes movement to be backward instead of forward.
24 COUNT defaults to 1. The current message remains selected after being
25 moved.
26
27 If vm-move-messages-physically is non-nil, the physical copy of
28 the message in the folder is moved. A nil value means just
29 change the presentation order and leave the physical order of
30 the folder undisturbed."
31 (interactive "p")
32 (vm-follow-summary-cursor)
33 (vm-select-folder-buffer)
34 (vm-check-for-killed-summary)
35 (vm-error-if-folder-empty)
36 (if vm-move-messages-physically
37 (vm-error-if-folder-read-only))
38 (vm-display nil nil '(vm-move-message-forward
39 vm-move-message-backward
40 vm-move-message-forward-physically
41 vm-move-message-backward-physically)
42 (list this-command))
43 (let* ((ovmp vm-message-pointer) vmp-prev ovmp-prev
44 (vm-message-pointer vm-message-pointer)
45 (direction (if (> count 0) 'forward 'backward))
46 (count (vm-abs count)))
47 (while (not (zerop count))
48 (vm-move-message-pointer direction)
49 (vm-decrement count))
50 (if (> (string-to-int (vm-number-of (car vm-message-pointer)))
51 (string-to-int (vm-number-of (car ovmp))))
52 (setq vm-message-pointer (cdr vm-message-pointer)))
53 (if (eq vm-message-pointer ovmp)
54 ()
55 (if (null vm-message-pointer)
56 (setq vmp-prev (vm-last vm-message-list))
57 (setq vmp-prev (vm-reverse-link-of (car vm-message-pointer))))
58 (setq ovmp-prev (vm-reverse-link-of (car ovmp)))
59 ;; lock out interrupts to preserve message list integrity.
60 (let ((inhibit-quit t))
61 (if ovmp-prev
62 (progn
63 (setcdr ovmp-prev (cdr ovmp))
64 (and (cdr ovmp)
65 (vm-set-reverse-link-of (car (cdr ovmp)) ovmp-prev)))
66 (setq vm-message-list (cdr ovmp))
67 (vm-set-reverse-link-of (car vm-message-list) nil))
68 (if vmp-prev
69 (progn
70 (setcdr vmp-prev ovmp)
71 (vm-set-reverse-link-of (car ovmp) vmp-prev))
72 (setq vm-message-list ovmp)
73 (vm-set-reverse-link-of (car vm-message-list) nil))
74 (setcdr ovmp vm-message-pointer)
75 (and vm-message-pointer
76 (vm-set-reverse-link-of (car vm-message-pointer) ovmp))
77 (if (and vm-move-messages-physically
78 (not (eq major-mode 'vm-virtual-mode)))
79 (vm-physically-move-message (car ovmp) (car vm-message-pointer)))
80 (setq vm-ml-sort-keys nil)
81 (if (not vm-folder-read-only)
82 (progn
83 (setq vm-message-order-changed t)
84 (vm-set-buffer-modified-p t)
85 (vm-clear-modification-flag-undos))))
86 (cond ((null ovmp-prev)
87 (setq vm-numbering-redo-start-point vm-message-list
88 vm-numbering-redo-end-point vm-message-pointer
89 vm-summary-pointer (car vm-message-list)))
90 ((null vmp-prev)
91 (setq vm-numbering-redo-start-point vm-message-list
92 vm-numbering-redo-end-point (cdr ovmp-prev)
93 vm-summary-pointer (car ovmp-prev)))
94 ((or (not vm-message-pointer)
95 (< (string-to-int (vm-number-of (car ovmp-prev)))
96 (string-to-int (vm-number-of (car vm-message-pointer)))))
97 (setq vm-numbering-redo-start-point (cdr ovmp-prev)
98 vm-numbering-redo-end-point (cdr ovmp)
99 vm-summary-pointer (car (cdr ovmp-prev))))
100 (t
101 (setq vm-numbering-redo-start-point ovmp
102 vm-numbering-redo-end-point (cdr ovmp-prev)
103 vm-summary-pointer (car ovmp-prev))))
104 (if vm-summary-buffer
105 (let (list mp)
106 (vm-copy-local-variables vm-summary-buffer 'vm-summary-pointer)
107 (setq vm-need-summary-pointer-update t)
108 (setq mp vm-numbering-redo-start-point)
109 (while (not (eq mp vm-numbering-redo-end-point))
110 (vm-mark-for-summary-update (car mp))
111 (setq list (cons (car mp) list)
112 mp (cdr mp)))
113 (vm-mapc
114 (function
115 (lambda (m p)
116 (vm-set-su-start-of m (car p))
117 (vm-set-su-end-of m (car (cdr p)))))
118 (setq list (nreverse list))
119 (sort
120 (mapcar
121 (function
122 (lambda (p)
123 (list (vm-su-start-of p) (vm-su-end-of p))))
124 list)
125 (function
126 (lambda (p q)
127 (< (car p) (car q))))))))))
128 (if vm-move-messages-physically
129 ;; clip region is messed up
130 (vm-preview-current-message)
131 (vm-update-summary-and-mode-line)))
132
133 (defun vm-move-message-backward (count)
134 "Move a message backward in a VM folder.
135 Prefix arg COUNT causes the current message to be moved COUNT
136 messages backward. A negative COUNT causes movement to be
137 forward instead of backward. COUNT defaults to 1. The current
138 message remains selected after being moved.
139
140 If vm-move-messages-physically is non-nil, the physical copy of
141 the message in the folder is moved. A nil value means just
142 change the presentation order and leave the physical order of
143 the folder undisturbed."
144 (interactive "p")
145 (vm-move-message-forward (- count)))
146
147 (defun vm-move-message-forward-physically (count)
148 "Like vm-move-message-forward but always move the message physically."
149 (interactive "p")
150 (let ((vm-move-messages-physically t))
151 (vm-move-message-forward count)))
152
153 (defun vm-move-message-backward-physically (count)
154 "Like vm-move-message-backward but always move the message physically."
155 (interactive "p")
156 (let ((vm-move-messages-physically t))
157 (vm-move-message-backward count)))
158
159 ;; move message m to be before m-dest
160 ;; and fix up the location markers afterwards.
161 ;; m better not equal m-dest.
162 ;; of m-dest is nil, move m to the end of buffer.
163 ;;
164 ;; consider carefully the effects of insertion on markers
165 ;; and variables containg markers before you modify this code.
166 (defun vm-physically-move-message (m m-dest)
167 (save-excursion
168 (vm-save-restriction
169 (widen)
170
171 ;; Make sure vm-headers-of and vm-text-of are non-nil in
172 ;; their slots before we try to move them. (Simply
173 ;; referencing the slot with their slot function is
174 ;; sufficient to guarantee this.) Otherwise, they be
175 ;; initialized in the middle of the message move and get the
176 ;; offset applied to them twice by way of a relative offset
177 ;; from one of the other location markers that has already
178 ;; been moved.
179 ;;
180 ;; Also, and more importantly, vm-vheaders-of might run
181 ;; vm-reorder-message-headers, which can add text to
182 ;; message. This MUST NOT happen after offsets have been
183 ;; computed for the message move or varying levels of chaos
184 ;; will ensue. In the case of BABYL files, where
185 ;; vm-reorder-message-headers can add a lot of new text,
186 ;; folder curroption can be massive.
187 (vm-text-of m)
188 (vm-vheaders-of m)
189
190 (let ((dest-start (if m-dest (vm-start-of m-dest) (point-max)))
191 (buffer-read-only nil)
192 offset doomed-start doomed-end)
193 (goto-char dest-start)
194 (insert-buffer-substring (current-buffer) (vm-start-of m) (vm-end-of m))
195 (setq doomed-start (marker-position (vm-start-of m))
196 doomed-end (marker-position (vm-end-of m))
197 offset (- (vm-start-of m) dest-start))
198 (set-marker (vm-start-of m) (- (vm-start-of m) offset))
199 (set-marker (vm-headers-of m) (- (vm-headers-of m) offset))
200 (set-marker (vm-text-end-of m) (- (vm-text-end-of m) offset))
201 (set-marker (vm-end-of m) (- (vm-end-of m) offset))
202 (set-marker (vm-text-of m) (- (vm-text-of m) offset))
203 (set-marker (vm-vheaders-of m) (- (vm-vheaders-of m) offset))
204 ;; now fix the start of m-dest since it didn't
205 ;; move forward with its message.
206 (and m-dest (set-marker (vm-start-of m-dest) (vm-end-of m)))
207 ;; delete the old copy of the message
208 (delete-region doomed-start doomed-end)))))
209
210 (defun vm-so-sortable-datestring (m)
211 (or (vm-sortable-datestring-of m)
212 (progn
213 (vm-set-sortable-datestring-of
214 m
215 (timezone-make-date-sortable
216 (or (vm-get-header-contents m "Date:")
217 (vm-grok-From_-date m)
218 "Thu, 1 Jan 1970 00:00:00 GMT")
219 "GMT" "GMT"))
220 (vm-sortable-datestring-of m))))
221
222 (defun vm-so-sortable-subject (m)
223 (or (vm-sortable-subject-of m)
224 (progn
225 (vm-set-sortable-subject-of
226 m
227 (let ((case-fold-search t)
228 (subject (vm-su-subject m)))
229 (if (and vm-subject-ignored-prefix
230 (string-match vm-subject-ignored-prefix subject)
231 (zerop (match-beginning 0)))
232 (setq subject (substring subject (match-end 0))))
233 (if (and vm-subject-ignored-suffix
234 (string-match vm-subject-ignored-suffix subject)
235 (= (match-end 0) (length subject)))
236 (setq subject (substring subject 0 (match-beginning 0))))
237 subject ))
238 (vm-sortable-subject-of m))))
239
240 (defun vm-sort-messages (keys &optional lets-get-physical)
241 "Sort message in a folder by the specified KEYS.
242 You may sort by more than one particular message key. If
243 messages compare equal by the first key, the second key will be
244 compared and so on. When called interactively the keys will be
245 read from the minibuffer. Valid keys are
246
247 \"date\" \"reversed-date\"
248 \"author\" \"reversed-author\"
249 \"subject\" \"reversed-subject\"
250 \"recipients\" \"reversed-recipients\"
251 \"line-count\" \"reversed-line-count\"
252 \"byte-count\" \"reversed-byte-count\"
253 \"physical-order\" \"reversed-physical-order\"
254
255 Optional second arg (prefix arg interactively) means the sort
256 should change the physical order of the messages in the folder.
257 Normally VM changes presentation order only, leaving the
258 folder in the order in which the messages arrived."
259 (interactive
260 (let ((last-command last-command)
261 (this-command this-command))
262 (list (vm-read-string (if (or current-prefix-arg
263 vm-move-messages-physically)
264 "Physically sort messages by: "
265 "Sort messages by: ")
266 vm-supported-sort-keys t)
267 current-prefix-arg)))
268 (vm-select-folder-buffer)
269 (vm-check-for-killed-summary)
270 ;; only squawk if interactive. The thread display uses this
271 ;; function and doesn't expect errors.
272 (if (interactive-p)
273 (vm-error-if-folder-empty))
274 ;; ditto
275 (if (and (interactive-p) (or vm-move-messages-physically lets-get-physical))
276 (vm-error-if-folder-read-only))
277 (vm-display nil nil '(vm-sort-messages) '(vm-sort-messages))
278 (let (key-list key-funcs key ml-keys
279 physical-order-list old-message-list new-message-list mp-old mp-new
280 old-start
281 doomed-start doomed-end offset
282 (order-did-change nil)
283 virtual
284 physical)
285 (setq key-list (vm-parse keys "[ \t]*\\([^ \t]+\\)")
286 ml-keys (and key-list (mapconcat (function identity) key-list "/"))
287 key-funcs nil
288 old-message-list vm-message-list
289 virtual (eq major-mode 'vm-virtual-mode)
290 physical (and (or lets-get-physical
291 vm-move-messages-physically)
292 (not vm-folder-read-only)
293 (not virtual)))
294 (or key-list (error "No sort keys specified."))
295 (while key-list
296 (setq key (car key-list))
297 (cond ((equal key "thread")
298 (vm-build-threads-if-unbuilt)
299 (setq key-funcs (cons 'vm-sort-compare-thread key-funcs)))
300 ((equal key "author")
301 (setq key-funcs (cons 'vm-sort-compare-author key-funcs)))
302 ((equal key "reversed-author")
303 (setq key-funcs (cons 'vm-sort-compare-author-r key-funcs)))
304 ((equal key "date")
305 (setq key-funcs (cons 'vm-sort-compare-date key-funcs)))
306 ((equal key "reversed-date")
307 (setq key-funcs (cons 'vm-sort-compare-date-r key-funcs)))
308 ((equal key "subject")
309 (setq key-funcs (cons 'vm-sort-compare-subject key-funcs)))
310 ((equal key "reversed-subject")
311 (setq key-funcs (cons 'vm-sort-compare-subject-r key-funcs)))
312 ((equal key "recipients")
313 (setq key-funcs (cons 'vm-sort-compare-recipients key-funcs)))
314 ((equal key "reversed-recipients")
315 (setq key-funcs (cons 'vm-sort-compare-recipients-r key-funcs)))
316 ((equal key "byte-count")
317 (setq key-funcs (cons 'vm-sort-compare-byte-count key-funcs)))
318 ((equal key "reversed-byte-count")
319 (setq key-funcs (cons 'vm-sort-compare-byte-count-r key-funcs)))
320 ((equal key "line-count")
321 (setq key-funcs (cons 'vm-sort-compare-line-count key-funcs)))
322 ((equal key "reversed-line-count")
323 (setq key-funcs (cons 'vm-sort-compare-line-count-r key-funcs)))
324 ((equal key "physical-order")
325 (setq key-funcs (cons 'vm-sort-compare-physical-order key-funcs)))
326 ((equal key "reversed-physical-order")
327 (setq key-funcs (cons 'vm-sort-compare-physical-order-r key-funcs)))
328 (t (error "Unknown key: %s" key)))
329 (setq key-list (cdr key-list)))
330 (vm-unsaved-message "Sorting...")
331 (let ((vm-key-functions (nreverse key-funcs)))
332 (setq new-message-list (sort (copy-sequence old-message-list)
333 'vm-sort-compare-xxxxxx))
334 ;; only need to do this sort if we're going to physically
335 ;; move messages later.
336 (if physical
337 (setq vm-key-functions '(vm-sort-compare-physical-order)
338 physical-order-list (sort (copy-sequence old-message-list)
339 'vm-sort-compare-xxxxxx))))
340 (vm-unsaved-message "Sorting... done")
341 (let ((inhibit-quit t))
342 (setq mp-old old-message-list
343 mp-new new-message-list)
344 (while mp-new
345 (if (eq (car mp-old) (car mp-new))
346 (setq mp-old (cdr mp-old)
347 mp-new (cdr mp-new))
348 (setq order-did-change t)
349 ;; unless a full redo has been requested, the numbering
350 ;; start point now points to a cons in the old message
351 ;; list. therefore we just change the variable
352 ;; directly to avoid the list scan that
353 ;; vm-set-numbering-redo-start-point does.
354 (cond ((not (eq vm-numbering-redo-start-point t))
355 (setq vm-numbering-redo-start-point mp-new
356 vm-numbering-redo-end-point nil)))
357 (if vm-summary-buffer
358 (progn
359 (setq vm-need-summary-pointer-update t)
360 ;; same logic as numbering reset above...
361 (cond ((not (eq vm-summary-redo-start-point t))
362 (setq vm-summary-redo-start-point mp-new)))
363 ;; start point of this message's summary is now
364 ;; wrong relative to where it is in the
365 ;; message list. fix it and the summary rebuild
366 ;; will take care of the rest.
367 (vm-set-su-start-of (car mp-new)
368 (vm-su-start-of (car mp-old)))))
369 (setq mp-new nil)))
370 (if (and order-did-change physical)
371 (let ((buffer-read-only nil))
372 ;; the folder is being physically ordered so we don't
373 ;; need a message order header to be stuffed, nor do
374 ;; we need to retain one in the folder buffer. so we
375 ;; strip out any existing message order header and
376 ;; say there are no changes to prevent a message
377 ;; order header from being stuffed later.
378 (vm-remove-message-order)
379 (setq vm-message-order-changed nil)
380 (vm-unsaved-message "Moving messages... ")
381 (widen)
382 (setq mp-old physical-order-list
383 mp-new new-message-list)
384 (setq old-start (vm-start-of (car mp-old)))
385 (while mp-new
386 (if (< (vm-start-of (car mp-old)) old-start)
387 ;; already moved this message
388 (setq mp-old (cdr mp-old))
389 (if (eq (car mp-old) (car mp-new))
390 (setq mp-old (cdr mp-old)
391 mp-new (cdr mp-new))
392 ;; move message
393 (vm-physically-move-message (car mp-new) (car mp-old))
394 ;; record start position. if vm-start-of
395 ;; mp-old ever becomes less than old-start
396 ;; we're running into messages that have
397 ;; already been moved.
398 (setq old-start (vm-start-of (car mp-old)))
399 ;; move mp-new but not mp-old because we moved
400 ;; mp-old down one message by inserting a
401 ;; message in front of it.
402 (setq mp-new (cdr mp-new)))))
403 (vm-unsaved-message "Moving messages... done")
404 (vm-set-buffer-modified-p t)
405 (vm-clear-modification-flag-undos))
406 (if (and order-did-change (not vm-folder-read-only))
407 (progn
408 (setq vm-message-order-changed t)
409 (vm-set-buffer-modified-p t)
410 (vm-clear-modification-flag-undos))))
411 (setq vm-ml-sort-keys ml-keys)
412 (intern (buffer-name) vm-buffers-needing-display-update)
413 (cond (order-did-change
414 (setq vm-message-list new-message-list)
415 (vm-reverse-link-messages)
416 (if vm-message-pointer
417 (setq vm-message-pointer
418 (or (cdr (vm-reverse-link-of (car vm-message-pointer)))
419 vm-message-list)))
420 (if vm-last-message-pointer
421 (setq vm-last-message-pointer
422 (or (cdr (vm-reverse-link-of
423 (car vm-last-message-pointer)))
424 vm-message-list))))))
425 (if (and vm-message-pointer
426 order-did-change
427 (or lets-get-physical vm-move-messages-physically))
428 ;; clip region is most likely messed up
429 (vm-preview-current-message)
430 (vm-update-summary-and-mode-line))))
431
432 (defun vm-sort-compare-xxxxxx (m1 m2)
433 (let ((key-funcs vm-key-functions) result)
434 (while (and key-funcs
435 (eq '= (setq result (funcall (car key-funcs) m1 m2))))
436 (setq key-funcs (cdr key-funcs)))
437 (and key-funcs result) ))
438
439 (defun vm-sort-compare-thread (m1 m2)
440 (let ((list1 (vm-th-thread-list m1))
441 (list2 (vm-th-thread-list m2)))
442 (catch 'done
443 (if (not (eq (car list1) (car list2)))
444 (let ((date1 (get (car list1) 'oldest-date))
445 (date2 (get (car list2) 'oldest-date)))
446 (cond ((string-lessp date1 date2) t)
447 ((string-equal date1 date2) '=)
448 (t nil)))
449 (while (and list1 list2)
450 (cond ((string-lessp (car list1) (car list2)) (throw 'done t))
451 ((not (string-equal (car list1) (car list2)))
452 (throw 'done nil)))
453 (setq list1 (cdr list1)
454 list2 (cdr list2)))
455 (cond ((and list1 (not list2)) nil)
456 ((and list2 (not list1)) t)
457 (t '=))))))
458
459 (defun vm-sort-compare-author (m1 m2)
460 (let ((s1 (vm-su-from m1))
461 (s2 (vm-su-from m2)))
462 (cond ((string-lessp s1 s2) t)
463 ((string-equal s1 s2) '=)
464 (t nil))))
465
466 (defun vm-sort-compare-author-r (m1 m2)
467 (let ((s1 (vm-su-from m1))
468 (s2 (vm-su-from m2)))
469 (cond ((string-lessp s1 s2) nil)
470 ((string-equal s1 s2) '=)
471 (t t))))
472
473 (defun vm-sort-compare-date (m1 m2)
474 (let ((s1 (vm-so-sortable-datestring m1))
475 (s2 (vm-so-sortable-datestring m2)))
476 (cond ((string-lessp s1 s2) t)
477 ((string-equal s1 s2) '=)
478 (t nil))))
479
480 (defun vm-sort-compare-date-r (m1 m2)
481 (let ((s1 (vm-so-sortable-datestring m1))
482 (s2 (vm-so-sortable-datestring m2)))
483 (cond ((string-lessp s1 s2) nil)
484 ((string-equal s1 s2) '=)
485 (t t))))
486
487 (defun vm-sort-compare-recipients (m1 m2)
488 (let ((s1 (vm-su-to m1))
489 (s2 (vm-su-to m2)))
490 (cond ((string-lessp s1 s2) t)
491 ((string-equal s1 s2) '=)
492 (t nil))))
493
494 (defun vm-sort-compare-recipients-r (m1 m2)
495 (let ((s1 (vm-su-to m1))
496 (s2 (vm-su-to m2)))
497 (cond ((string-lessp s1 s2) nil)
498 ((string-equal s1 s2) '=)
499 (t t))))
500
501 (defun vm-sort-compare-subject (m1 m2)
502 (let ((s1 (vm-so-sortable-subject m1))
503 (s2 (vm-so-sortable-subject m2)))
504 (cond ((string-lessp s1 s2) t)
505 ((string-equal s1 s2) '=)
506 (t nil))))
507
508 (defun vm-sort-compare-subject-r (m1 m2)
509 (let ((s1 (vm-so-sortable-subject m1))
510 (s2 (vm-so-sortable-subject m2)))
511 (cond ((string-lessp s1 s2) nil)
512 ((string-equal s1 s2) '=)
513 (t t))))
514
515 (defun vm-sort-compare-line-count (m1 m2)
516 (let ((n1 (string-to-int (vm-su-line-count m1)))
517 (n2 (string-to-int (vm-su-line-count m2))))
518 (cond ((< n1 n2) t)
519 ((= n1 n2) '=)
520 (t nil))))
521
522 (defun vm-sort-compare-line-count-r (m1 m2)
523 (let ((n1 (string-to-int (vm-su-line-count m1)))
524 (n2 (string-to-int (vm-su-line-count m2))))
525 (cond ((> n1 n2) t)
526 ((= n1 n2) '=)
527 (t nil))))
528
529 (defun vm-sort-compare-byte-count (m1 m2)
530 (let ((n1 (string-to-int (vm-su-byte-count m1)))
531 (n2 (string-to-int (vm-su-byte-count m2))))
532 (cond ((< n1 n2) t)
533 ((= n1 n2) '=)
534 (t nil))))
535
536 (defun vm-sort-compare-byte-count-r (m1 m2)
537 (let ((n1 (string-to-int (vm-su-byte-count m1)))
538 (n2 (string-to-int (vm-su-byte-count m2))))
539 (cond ((> n1 n2) t)
540 ((= n1 n2) '=)
541 (t nil))))
542
543 (defun vm-sort-compare-physical-order (m1 m2)
544 (let ((n1 (vm-start-of m1))
545 (n2 (vm-start-of m2)))
546 (cond ((< n1 n2) t)
547 ((= n1 n2) '=)
548 (t nil))))
549
550 (defun vm-sort-compare-physical-order-r (m1 m2)
551 (let ((n1 (vm-start-of m1))
552 (n2 (vm-start-of m2)))
553 (cond ((> n1 n2) t)
554 ((= n1 n2) '=)
555 (t nil))))