diff options
| author | David Aspinall | 1998-09-03 13:51:41 +0000 |
|---|---|---|
| committer | David Aspinall | 1998-09-03 13:51:41 +0000 |
| commit | 8b836f84d70fcea59ffa186f6809ebc6765b8a5f (patch) | |
| tree | 8dc74b560cadf3b6e847e547776ccd0015dfa7f1 /span-overlay.el | |
| parent | abbe57d8b69d79e9eb6899f182379d9c6c4fdc7f (diff) | |
Renamed for new subdirectory structure
Diffstat (limited to 'span-overlay.el')
| -rw-r--r-- | span-overlay.el | 288 |
1 files changed, 0 insertions, 288 deletions
diff --git a/span-overlay.el b/span-overlay.el deleted file mode 100644 index f74350ed..00000000 --- a/span-overlay.el +++ /dev/null @@ -1,288 +0,0 @@ -;;; This file implements spans in terms of overlays, for emacs19. -;;; Copyright (C) 1998 LFCS Edinburgh -;;; Author: Healfdene Goguen - -;; Maintainer: LEGO Team <lego@dcs.ed.ac.uk> - -;; $Log$ -;; Revision 2.0 1998/08/11 15:00:13 da -;; New branch -;; -;; Revision 1.9 1998/06/10 14:02:39 hhg -;; Wrote generic span functions for making spans read-only or read-write. -;; Fixed bug in add-span and remove-span concerning return value of -;; span-traverse. -;; -;; Revision 1.8 1998/06/10 12:41:47 hhg -;; Compare span-end first rather than span-start in span-lt, because -;; proof-lock-span is often changed and has starting point 1. -;; Factored out common code of add-span and remove-span into -;; span-traverse. -;; -;; 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. -;; -;; Revision 1.5 1998/05/29 09:50:10 tms -;; o outsourced indentation to proof-indent -;; o support indentation of commands -;; o replaced test of Emacs version with availability test of specific -;; features -;; o C-c C-c, C-c C-v and M-tab is now available in all buffers -;; -;; Revision 1.4 1998/05/21 17:27:41 hhg -;; Removed uninitialized os variable in spans-at-region. -;; -;; Revision 1.3 1998/05/21 08:28:52 hhg -;; Initialize 'before pointer in add-span-aux when last-span is nil. -;; Removed span-at-type. -;; Fixed bug in span-at-before, where (span-start span) may be nil. -;; Added spans-at-(point|region)[-prop], which fixes bug of C-c u at end -;; of buffer. -;; -;; Revision 1.2 1998/05/19 15:31:37 hhg -;; Added header and log message. -;; Fixed set-span-endpoints so it preserves invariant. -;; Changed add-span and remove-span so that they update last-span -;; correctly themselves, and don't take last-span as an argument. -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Bridging the emacs19/xemacs gulf ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; 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 before-list nil - "Start of backwards-linked list of spans") - -(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)) - -(defsubst span-end (span) - (overlay-end span)) - -(defun set-span-property (span name value) - (overlay-put span name value)) - -(defsubst span-property (span name) - (overlay-get span name)) - -(defun span-read-only-hook (overlay after start end &optional len) - (error "Region is read-only")) - -(defun span-read-only (span) - (set-span-property span 'modification-hooks '(span-read-only-hook)) - (set-span-property span 'insert-in-front-hooks '(span-read-only-hook))) - -(defun span-read-write (span) - (set-span-property span 'modification-hooks nil) - (set-span-property span 'insert-in-front-hooks nil)) - -(defun int-nil-lt (m n) - (cond - ((eq m n) nil) - ((not n) t) - ((not m) nil) - (t (< m n)))) - -;; We use end first because proof-locked-queue is often changed, and -;; its starting point is always 1 -(defun span-lt (s u) - (or (int-nil-lt (span-end s) (span-end u)) - (and (eq (span-end s) (span-end u)) - (int-nil-lt (span-start s) (span-start u))))) - -(defun span-traverse (span prop) - (cond - ((not before-list) - ;; before-list empty - 'empty) - ((funcall prop before-list span) - ;; property holds for before-list and span - 'hd) - (t - ;; traverse before-list for property - (let ((l before-list) (before (span-property before-list 'before))) - (while (and before (not (funcall prop before span))) - (setq l before) - (setq before (span-property before 'before))) - l)))) - -(defun add-span (span) - (let ((ans (span-traverse span 'span-lt))) - (cond - ((eq ans 'empty) - (set-span-property span 'before nil) - (setq before-list span)) - ((eq ans 'hd) - (set-span-property span 'before before-list) - (setq before-list span)) - (t - (set-span-property span 'before - (span-property ans 'before)) - (set-span-property ans 'before span))))) - -(defun make-span (start end) - (add-span (make-overlay start end))) - -(defun remove-span (span) - (let ((ans (span-traverse span 'eq))) - (cond - ((eq ans 'empty) - (error "Bug: empty span list")) - ((eq ans 'hd) - (setq before-list (span-property before-list 'before))) - (ans - (set-span-property ans 'before (span-property span 'before))) - (t (error "Bug: span does not occur in span list"))))) - -;; extent-at gives "smallest" extent at pos -;; we're assuming right now that spans don't overlap -(defun spans-at-point (pt) - (let ((overlays nil) (os nil)) - (setq os (overlays-at pt)) - (while os - (if (not (memq (car os) overlays)) - (setq overlays (cons (car os) overlays))) - (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-unique (spans-at-point pos) overlays)) - (setq pos (next-overlay-change pos))) - overlays)) - -(defun spans-at-point-prop (pt prop) - (let ((f (cond - (prop (lambda (spans span) - (if (span-property span prop) (cons span spans) - spans))) - (t (lambda (spans span) (cons span spans)))))) - (foldl f nil (spans-at-point pt)))) - -(defun spans-at-region-prop (start end prop) - (let ((f (cond - (prop (lambda (spans span) - (if (span-property span prop) (cons span spans) - spans))) - (t (lambda (spans span) (cons span spans)))))) - (foldl f nil (spans-at-region start end)))) - -(defun span-at (pt prop) - (car (spans-at-point-prop pt prop))) - -(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))) - -(defun map-spans-aux (f l) - (cond (l (cons (funcall f l) (map-spans-aux f (span-property l 'before)))) - (t ()))) - -(defsubst map-spans (f) - (map-spans-aux f before-list)) - -(defun find-span-aux (prop-p l) - (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 before-list)) - -(defun span-at-before (pt prop) - (let ((prop-pt-p - (cond (prop (lambda (span) - (let ((start (span-start span))) - (and start (> pt start) - (span-property span prop))))) - (t (lambda (span) - (let ((start (span-start span))) - (and start (> pt start)))))))) - (find-span prop-pt-p))) - -(defun prev-span (span prop) - (let ((prev-prop-p - (cond (prop (lambda (span) (span-property span prop))) - (t (lambda (span) t))))) - (find-span-aux prev-prop-p (span-property span 'before)))) - -;; overlays are [start, end) -;; If there are two spans overlapping then this won't work. -(defun next-span (span prop) - (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) |
