84 lines
3.0 KiB
Scheme
84 lines
3.0 KiB
Scheme
|
;;;; Permanent Marks
|
|||
|
|
|
|||
|
|
;;; The marks list is cleaned every time that a mark is added to the list,
|
|||
|
|
;;; and every time that FOR-EACH-MARK! is called. This should keep the
|
|||
|
|
;;; number of extraneous entries to a minimum. Note that FOR-EACH-MARK!
|
|||
|
|
;;; and SET-MARK-LINE! are intended to be used together; in particular,
|
|||
|
|
;;; a great deal of cleverness has been used to ensure that the changes
|
|||
|
|
;;; made by SET-MARK-LINE! are noticed by FOR-EACH-MARK!. This turned out
|
|||
|
|
;;; to be non-trivial to implement.
|
|||
|
|
|
|||
|
|
(define (mark-permanent! mark)
|
|||
|
|
(let ((n (object-hash mark))
|
|||
|
|
(marks (line-marks (mark-line mark))))
|
|||
|
|
(if (not (memv n marks))
|
|||
|
|
(let ((marks (cons n marks)))
|
|||
|
|
(begin (clean-marks-tail! marks)
|
|||
|
|
(set-line-marks! (mark-line mark) marks)))))
|
|||
|
|
mark)
|
|||
|
|
|
|||
|
|
(define (clean-marks-tail! marks)
|
|||
|
|
(if (not (null? (cdr marks)))
|
|||
|
|
(if (object-unhash (cadr marks))
|
|||
|
|
(clean-marks-tail! (cdr marks))
|
|||
|
|
(begin (set-cdr! marks (cddr marks))
|
|||
|
|
(clean-marks-tail! marks)))))
|
|||
|
|
|
|||
|
|
(define (for-each-mark! line procedure)
|
|||
|
|
(define (loop-1 marks)
|
|||
|
|
(if (not (null? marks))
|
|||
|
|
(let ((mark (object-unhash (car marks))))
|
|||
|
|
(if mark
|
|||
|
|
(begin (procedure mark #!false)
|
|||
|
|
(if (eq? marks (line-marks line))
|
|||
|
|
(loop-2 marks (cdr marks))
|
|||
|
|
(loop-1 (line-marks line))))
|
|||
|
|
(begin (set-line-marks! line (cdr marks))
|
|||
|
|
(loop-1 (line-marks line)))))))
|
|||
|
|
(define (loop-2 previous marks)
|
|||
|
|
(if (not (null? marks))
|
|||
|
|
(let ((mark (object-unhash (car marks))))
|
|||
|
|
(if mark
|
|||
|
|
(begin (procedure mark #!false)
|
|||
|
|
(if (eq? marks (cdr previous))
|
|||
|
|
(loop-2 marks (cdr marks))
|
|||
|
|
(loop-2 previous (cdr previous))))
|
|||
|
|
(begin (set-cdr! previous (cddr previous))
|
|||
|
|
(loop-2 previous (cdr previous)))))))
|
|||
|
|
|
|||
|
|
;;; point is treated as a special case and is no longer a permanent mark
|
|||
|
|
;;; This would decrease the number of permanent marks considerably.
|
|||
|
|
;;; Permannet marks are not so cheap and should be used only when
|
|||
|
|
;;; really needed. Currently the point is obtained from current point
|
|||
|
|
;;; but in a general setting there should be a way to get back to the
|
|||
|
|
;;; buffer from group to get the point.
|
|||
|
|
|
|||
|
|
(let ((point (current-point)))
|
|||
|
|
(if (and (eq? line (mark-line point))
|
|||
|
|
(let ((n (object-hash point)))
|
|||
|
|
(not (memv n (line-marks line)))))
|
|||
|
|
(procedure point #!true)))
|
|||
|
|
(loop-1 (line-marks line)))
|
|||
|
|
|
|||
|
|
(define (set-mark-line! mark new-line)
|
|||
|
|
(let ((old-line (mark-line mark)))
|
|||
|
|
(cond ((not (eq? old-line new-line))
|
|||
|
|
(let ((marks
|
|||
|
|
(let ((n (object-hash mark))
|
|||
|
|
(marks (line-marks old-line)))
|
|||
|
|
(define (loop previous marks)
|
|||
|
|
(if (= n (car marks))
|
|||
|
|
(begin (set-cdr! previous (cdr marks))
|
|||
|
|
marks)
|
|||
|
|
(loop marks (cdr marks))))
|
|||
|
|
(if (= n (car marks))
|
|||
|
|
(begin (set-line-marks! old-line (cdr marks))
|
|||
|
|
marks)
|
|||
|
|
(loop marks (cdr marks))))))
|
|||
|
|
(%set-mark-line! mark new-line)
|
|||
|
|
(set-cdr! marks (line-marks new-line))
|
|||
|
|
(clean-marks-tail! marks)
|
|||
|
|
(set-line-marks! new-line marks))))))
|
|||
|
|
|
|||
|
|
|