From 4257ca2e973a34c4bdb6ab6f9d7371b4dcabe779 Mon Sep 17 00:00:00 2001
From: Healfdene Goguen
Date: Wed, 3 Jun 1998 17:40:07 +0000
Subject: 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.

---
 span-overlay.el | 202 +++++++++++++++++++++++++++++++++++---------------------
 1 file 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)
-- 
cgit v1.2.3