Mercurial > hg > xemacs-beta

comparison lisp/format.el @ 5473:ac37a5f7e5be

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Thu, 17 Mar 2011 23:42:59 +0100
parents 308d34e9f07d dbae25a8949d
children
comparison
equal deleted inserted replaced
5472:e79980ee5efe 5473:ac37a5f7e5be
432 (set-text-properties (- (point) (length to)) (point) 432 (set-text-properties (- (point) (length to)) (point)
433 (text-properties-at (point))) 433 (text-properties-at (point)))
434 (delete-region (point) (+ (point) (- (match-end 0) 434 (delete-region (point) (+ (point) (- (match-end 0)
435 (match-beginning 0))))) 435 (match-beginning 0)))))
436 (setq alist (cdr alist))))))) 436 (setq alist (cdr alist)))))))
437
438 ;;; Some list-manipulation functions that we need.
439
440 (defun format-delq-cons (cons list)
441 "Remove the given CONS from LIST by side effect,
442 and return the new LIST. Since CONS could be the first element
443 of LIST, write `\(setq foo \(format-delq-cons element foo))' to be sure of
444 changing the value of `foo'."
445 (if (eq cons list)
446 (cdr list)
447 (let ((p list))
448 (while (not (eq (cdr p) cons))
449 (if (null p) (error "format-delq-cons: not an element."))
450 (setq p (cdr p)))
451 ;; Now (cdr p) is the cons to delete
452 (setcdr p (cdr cons))
453 list)))
454
455 ;; XEmacs: this is #'nset-exclusive-or with a :test of #'equal, though we
456 ;; probably don't want to replace it right now.
457 (defun format-make-relatively-unique (a b)
458 "Delete common elements of lists A and B, return as pair.
459 Compares using `equal'."
460 (let* ((acopy (copy-sequence a))
461 (bcopy (copy-sequence b))
462 (tail acopy))
463 (while tail
464 (let ((dup (member (car tail) bcopy))
465 (next (cdr tail)))
466 (if dup (setq acopy (format-delq-cons tail acopy)
467 bcopy (format-delq-cons dup bcopy)))
468 (setq tail next)))
469 (cons acopy bcopy)))
470
471 (defun format-common-tail (a b)
472 "Given two lists that have a common tail, return it.
473 Compares with `equal', and returns the part of A that is equal to the
474 equivalent part of B. If even the last items of the two are not equal,
475 returns nil."
476 (let ((la (length a))
477 (lb (length b)))
478 ;; Make sure they are the same length
479 (if (> la lb)
480 (setq a (nthcdr (- la lb) a))
481 (setq b (nthcdr (- lb la) b))))
482 (while (not (equal a b))
483 (setq a (cdr a)
484 b (cdr b)))
485 a)
486
487 (defun format-reorder (items order)
488 "Arrange ITEMS to following partial ORDER.
489 Elements of ITEMS equal to elements of ORDER will be rearranged to follow the
490 ORDER. Unmatched items will go last."
491 (if order
492 (let ((item (member (car order) items)))
493 (if item
494 (cons (car item)
495 (format-reorder (format-delq-cons item items)
496 (cdr order)))
497 (format-reorder items (cdr order))))
498 items))
499 437
500 (put 'face 'format-list-valued t) ; These text-properties take values 438 (put 'face 'format-list-valued t) ; These text-properties take values
501 (put 'unknown 'format-list-valued t) ; that are lists, the elements of which 439 (put 'unknown 'format-list-valued t) ; that are lists, the elements of which
502 ; should be considered separately. 440 ; should be considered separately.
503 ; See format-deannotate-region and 441 ; See format-deannotate-region and
816 (while (or (null loc) 754 (while (or (null loc)
817 (and (setq loc (next-property-change loc nil to)) 755 (and (setq loc (next-property-change loc nil to))
818 (< loc to))) 756 (< loc to)))
819 (or loc (setq loc from)) 757 (or loc (setq loc from))
820 (let* ((ans (format-annotate-location loc (= loc from) ignore trans)) 758 (let* ((ans (format-annotate-location loc (= loc from) ignore trans))
821 (neg-ans (format-reorder (aref ans 0) open-ans)) 759 (neg-ans (sort* (aref ans 0) '<
760 :key #'(lambda (object)
761 (or
762 (position object open-ans :test 'equal)
763 most-positive-fixnum))))
822 (pos-ans (aref ans 1)) 764 (pos-ans (aref ans 1))
823 (ignored (aref ans 2))) 765 (ignored (aref ans 2)))
824 (setq not-found (append ignored not-found) 766 (setq not-found (append ignored not-found)
825 ignore (append ignored ignore)) 767 ignore (append ignored ignore))
826 ;; First do the negative (closing) annotations 768 ;; First do the negative (closing) annotations
925 nil 867 nil
926 ;; If either old or new is a list, have to treat both that way. 868 ;; If either old or new is a list, have to treat both that way.
927 (if (or (consp old) (consp new)) 869 (if (or (consp old) (consp new))
928 (let* ((old (if (listp old) old (list old))) 870 (let* ((old (if (listp old) old (list old)))
929 (new (if (listp new) new (list new))) 871 (new (if (listp new) new (list new)))
930 ;; (tail (format-common-tail old new))
931 close open) 872 close open)
932 (while old 873 (while old
933 (setq close 874 (setq close
934 (append (car (format-annotate-atomic-property-change 875 (append (car (format-annotate-atomic-property-change
935 prop-alist (car old) nil)) 876 prop-alist (car old) nil))
939 (setq open 880 (setq open
940 (append (cdr (format-annotate-atomic-property-change 881 (append (cdr (format-annotate-atomic-property-change
941 prop-alist nil (car new))) 882 prop-alist nil (car new)))
942 open) 883 open)
943 new (cdr new))) 884 new (cdr new)))
944 (format-make-relatively-unique close open)) 885 (cons
886 (set-difference close open :stable t)
887 (set-difference open close :stable t)))
945 (format-annotate-atomic-property-change prop-alist old new))))) 888 (format-annotate-atomic-property-change prop-alist old new)))))
946 889
947 (defun format-annotate-atomic-property-change (prop-alist old new) 890 (defun format-annotate-atomic-property-change (prop-alist old new)
948 "Internal function annotate a single property change. 891 "Internal function annotate a single property change.
949 PROP-ALIST is the relevant segment of a TRANSLATIONS list. 892 PROP-ALIST is the relevant segment of a TRANSLATIONS list.
976 919
977 ;; Standard annotation 920 ;; Standard annotation
978 (let ((close (and old (cdr (assoc old prop-alist)))) 921 (let ((close (and old (cdr (assoc old prop-alist))))
979 (open (and new (cdr (assoc new prop-alist))))) 922 (open (and new (cdr (assoc new prop-alist)))))
980 (if (or close open) 923 (if (or close open)
981 (format-make-relatively-unique close open) 924 (cons
925 (set-difference close open :stable t)
926 (set-difference open close :stable t))
982 ;; Call "Default" function, if any 927 ;; Call "Default" function, if any
983 (let ((default (assq nil prop-alist))) 928 (let ((default (assq nil prop-alist)))
984 (if default 929 (if default
985 (funcall (car (cdr default)) old new)))))))) 930 (funcall (car (cdr default)) old new))))))))
986 931