diff options
| -rw-r--r-- | span-overlay.el | 202 |
1 files changed, 126 insertions, 76 deletions
diff --git a/span-overlay.el b/span-overlay.el index c0f99d1c..7007b163 100644 --- a/span-overlay.el +++ b/span-overlay.el @@ -5,6 +5,16 @@ ;; Maintainer: LEGO Team <lego@dcs.ed.ac.uk> ;; $Log$ +;; Revision 1.7 1998/06/03 17:40:07 hhg +;; Changed last-span to before-list. +;; Added definitions of foldr and foldl if they aren't already loaded. +;; Changed definitions of add-span, remove-span and find-span-aux to be +;; non-recursive. +;; Removed detach-extent since this file isn't used by xemacs. +;; Added function append-unique to avoid repetitions in list generated by +;; spans-at-region. +;; Changed next-span so it uses member-if. +;; ;; Revision 1.6 1998/06/02 15:36:51 hhg ;; Corrected comment about this being for emacs19. ;; @@ -36,15 +46,42 @@ ;; Bridging the emacs19/xemacs gulf ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; last-span represents a linked list of spans for each buffer. -;; It has the invariant of being ordered wrt the starting point of -;; the spans in the list, with detached spans at the end. +;; before-list represents a linked list of spans for each buffer. +;; It has the invariants of: +;; * being ordered wrt the starting point of the spans in the list, +;; with detached spans at the end. +;; * not having overlapping overlays of the same type. -(defvar last-span nil +(defvar before-list nil "Start of backwards-linked list of spans") -(make-variable-buffer-local 'last-span) - +(make-variable-buffer-local 'before-list) + + +(or (fboundp 'foldr) +(defun foldr (func a seq) + "Return (func (func (func (... (func a Sn) ...) S2) S1) S0) +when func's argument is 2 and seq is a sequence whose +elements = S0 S1 S2 ... Sn. [tl-seq.el]" + (let ((i (length seq))) + (while (> i 0) + (setq i (1- i)) + (setq a (funcall func a (elt seq i))) + ) + a))) + +(or (fboundp 'foldl) +(defun foldl (func a seq) + "Return (... (func (func (func a S0) S1) S2) ...) +when func's argument is 2 and seq is a sequence whose +elements = S0 S1 S2 .... [tl-seq.el]" + (let ((len (length seq)) + (i 0)) + (while (< i len) + (setq a (funcall func a (elt seq i))) + (setq i (1+ i)) + ) + a))) (defsubst span-start (span) (overlay-start span)) @@ -52,70 +89,38 @@ (defsubst span-end (span) (overlay-end span)) -(defsubst span-property (span name) - (overlay-get span name)) - -(defsubst set-span-property (span name value) - (overlay-put span name value)) +(defun int-nil-lt (m n) + (cond + ((eq m n) nil) + ((not n) t) + ((not m) nil) + (t (< m n)))) -(defun span-lt (s t) - (or (not (span-start t)) - (and (span-start s) - (< (span-start s) (span-start t))))) +(defun span-lt (s u) + (or (int-nil-lt (span-start s) (span-start u)) + (and (eq (span-start s) (span-start u)) + (int-nil-lt (span-end s) (span-end u))))) (defun add-span (span) - (if last-span - (let ((l last-span) (cont (span-lt span l)) tmp) - (while (and l cont) - (if (not (span-property l 'before)) - (setq cont nil) - (setq l (span-property l 'before)) - (setq cont (span-lt span l)))) - (setq tmp (span-property l 'before)) - (set-span-property l 'before span) - (set-span-property span 'before tmp)) - (setq last-span span) - (set-span-property span 'before nil)) - span) + (cond + ((not before-list) + (set-span-property span 'before nil) + (setq before-list span)) + ((span-lt before-list span) + (set-span-property span 'before before-list) + (setq before-list span)) + (t + (let ((l before-list) (before (span-property before-list 'before))) + (while (and before (span-lt span before)) + (setq l before) + (setq before (span-property before 'before))) + (set-span-property l 'before span) + (set-span-property span 'before before)) + span))) (defun make-span (start end) (add-span (make-overlay start end))) -(defun remove-span-aux (span l) - (cond ((not l) (error "Bug: removing span from empty list")) - ((eq span (span-property l 'before)) - (set-span-property l 'before (span-property span 'before)) - l) - (t (remove-span-aux span (span-property l 'before))))) - -(defun remove-span (span) - (cond ((not last-span) (error "Bug: empty span list")) - ((eq span last-span) - (setq last-span (span-property last-span 'before))) - (t (remove-span-aux span last-span)))) - -(defsubst detach-span (span) - (remove-span span) - (delete-overlay span) - (add-span span)) - -(defsubst delete-span (span) - (remove-span span) - (delete-overlay span)) - -;; The next two change ordering of list of spans: -(defsubst set-span-endpoints (span start end) - (remove-span span) - (move-overlay span start end) - (add-span span)) - -(defsubst set-span-start (span value) - (set-span-endpoints span value (span-end span))) - -;; This doesn't affect invariant: -(defsubst set-span-end (span value) - (set-span-endpoints span (span-start span) value)) - ;; extent-at gives "smallest" extent at pos ;; we're assuming right now that spans don't overlap (defun spans-at-point (pt) @@ -127,10 +132,14 @@ (setq os (cdr os))) overlays)) +;; assumes that there are no repetitions in l or m +(defun append-unique (l m) + (foldl (lambda (n a) (if (memq a m) n (cons a n))) m l)) + (defun spans-at-region (start end) (let ((overlays nil) (pos start)) (while (< pos end) - (setq overlays (append (spans-at-point pos) overlays)) + (setq overlays (append-unique (spans-at-point pos) overlays)) (setq pos (next-overlay-change pos))) overlays)) @@ -153,6 +162,49 @@ (defun span-at (pt prop) (car (spans-at-point-prop pt prop))) +(defsubst span-property (span name) + (overlay-get span name)) + +(defun set-span-property (span name value) + (overlay-put span name value)) + +(defun remove-span (span) + (cond + ((not before-list) + (error "Bug: empty span list")) + ((eq before-list span) + (setq before-list (span-property before-list 'before))) + (t + (let ((l before-list) (before (span-property before-list 'before))) + (while (and before (not (eq span before))) + (setq l before) + (setq before (span-property before 'before))) + (if before + (set-span-property l 'before (span-property span 'before)) + (error "Bug: span does not occur in span list")))))) + +(defsubst detach-span (span) + (remove-span span) + (delete-overlay span) + (add-span span)) + +(defsubst delete-span (span) + (remove-span span) + (delete-overlay span)) + +;; The next two change ordering of list of spans: +(defsubst set-span-endpoints (span start end) + (remove-span span) + (move-overlay span start end) + (add-span span)) + +(defsubst set-span-start (span value) + (set-span-endpoints span value (span-end span))) + +;; This doesn't affect invariant: +(defsubst set-span-end (span value) + (set-span-endpoints span (span-start span) value)) + (defsubst delete-spans (start end prop) (mapcar 'delete-span (spans-at-region-prop start end prop))) @@ -161,15 +213,15 @@ (t ()))) (defsubst map-spans (f) - (map-spans-aux f last-span)) + (map-spans-aux f before-list)) (defun find-span-aux (prop-p l) - (cond ((not l) ()) - ((funcall prop-p l) l) - (t (find-span-aux prop-p (span-property l 'before))))) + (while (and l (not (funcall prop-p l))) + (setq l (span-property l 'before))) + l) (defun find-span (prop-p) - (find-span-aux prop-p last-span)) + (find-span-aux prop-p before-list)) (defun span-at-before (pt prop) (let ((prop-pt-p @@ -188,15 +240,13 @@ (t (lambda (span) t))))) (find-span-aux prev-prop-p (span-property span 'before)))) -(defun next-span-aux (prop spans) - (cond ((not spans) nil) - ((span-property (car spans) prop) (car spans)) - (t (next-span-aux prop (cdr spans))))) - ;; overlays are [start, end) +;; If there are two spans overlapping then this won't work. (defun next-span (span prop) - (next-span-aux prop - (overlays-at (next-overlay-change (overlay-start span))))) + (let ((l (member-if (lambda (span) (span-property span prop)) + (overlays-at + (next-overlay-change (overlay-start span)))))) + (if l (car l) nil))) (provide 'span-overlay) |