Mercurial > hg > xemacs-beta

comparison lisp/format.el @ 5365:dbae25a8949d

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