4ff9369986d3fcae4e7f7a15f081ed8302ff6453
1 ;;; buffer inserting, deleting, gap management, etc
5 ;; (defun gap-close (buf)
6 ;; "Move the gap to the end of the buffer."
7 ;; (let ((gap-start (buffer-gap-start buf))
8 ;; (gap-end (gap-end buf)))
9 ;; (setf (buffer-gap-start buf) (- (length (buffer-data buf)) (buffer-gap-size buf)))
10 ;; (replace (buffer-data buf) (buffer-data buf) :start1 gap-start :start2 gap-end)))
12 (defun grow-buffer-data (buf size
)
13 "Grow the buffer data array to be SIZE. SIZE must be larger than before."
14 ;; MOVITZ doesn't have adjust-array
15 ;; ;; #\_ is used for debugging to represent the gap
16 ;; (adjust-array (buffer-data buf) size :initial-element #\_ :fill-pointer t)
17 (let ((newbuf (make-array size
:initial-element
#\_
;; :fill-pointer t
18 :element-type
'character
)))
19 (replace newbuf
(buffer-data buf
))
20 (setf (buffer-data buf
) newbuf
)))
22 (defun gap-extend (buf size
)
23 "Extend the gap by SIZE characters."
24 (let ((new-size (+ (length (buffer-data buf
)) size
))
25 (old-end (gap-end buf
))
26 (old-size (buffer-size buf
))
27 (data (buffer-data buf
)))
28 (setf data
(grow-buffer-data buf new-size
))
29 (incf (buffer-gap-size buf
) size
)
30 (unless (= (buffer-gap-start buf
) old-size
)
34 ;; for debugging, mark the gap
37 ;; (defun buffer-char-before-point (buf p)
38 ;; "The character at the point P in buffer BUF. P is in char space."
39 ;; (declare (type buffer buf)
41 ;; (let ((aref (buffer-char-to-aref buf p)))
42 ;; (when (< aref (length (buffer-data buf)))
43 ;; (aref (buffer-data buf) aref))))
45 (defgeneric buffer-insert
(buffer object
)
46 (:documentation
"Insert OBJECT into BUFFER at the current point."))
48 (defmethod buffer-insert :after
((buf buffer
) object
)
49 "Any object insertion modifies the buffer."
50 (declare (ignore object
))
51 (setf (buffer-modified-p buf
) t
))
53 (defmethod buffer-insert ((buf buffer
) (char character
))
54 "Insert a single character into buffer before point."
55 ;; Resize the gap if needed
56 (if (<= (buffer-gap-size buf
) 1)
58 ;; Move the gap to the point
59 (unless (= (pt buf
) (buffer-gap-start buf
))
60 (gap-move-to buf
(buffer-point-aref buf
)))
61 (update-markers-ins buf
(pt buf
) 1)
63 (record-insert (pt buf
) 1 buf
)
65 (setf (aref (buffer-data buf
) (buffer-gap-start buf
)) char
)
66 ;; move the gap forward
67 (incf (buffer-gap-start buf
))
68 (decf (buffer-gap-size buf
))
69 ;; expand the buffer intervals
70 (offset-intervals buf
(pt buf
) 1))
72 (defmethod buffer-insert ((buf buffer
) (string string
))
74 (when (<= (buffer-gap-size buf
) (length string
))
75 (gap-extend buf
(+ (length string
) 100)))
76 ;; move the gap to the point
77 (unless (= (pt buf
) (buffer-gap-start buf
))
78 (gap-move-to buf
(buffer-point-aref buf
)))
79 (update-markers-ins buf
(pt buf
) (length string
))
81 (record-insert (pt buf
) (length string
) buf
)
83 (replace (buffer-data buf
) string
:start1
(buffer-gap-start buf
))
84 (incf (buffer-gap-start buf
) (length string
))
85 (decf (buffer-gap-size buf
) (length string
))
86 ;; expand the buffer intervals
87 (offset-intervals buf
(pt buf
) (length string
)))
89 (defmethod buffer-insert ((buf buffer
) (string pstring
))
91 (buffer-insert buf
(pstring-data string
))
93 (graft-intervals-into-buffer (intervals string
)
95 (pstring-length string
)
99 (defgeneric insert-move-point
(buffer object
)
100 (:documentation
"Insert OBJECT into BUFFER at the current point. Move the point
101 forward by its length."))
103 (defmethod insert-move-point ((buffer buffer
) (object character
))
104 (buffer-insert buffer object
)
105 (incf (marker-position (buffer-point buffer
))))
107 (defmethod insert-move-point ((buffer buffer
) (object string
))
108 (buffer-insert buffer object
)
109 (incf (marker-position (buffer-point buffer
)) (length object
)))
111 (defmethod insert-move-point ((buffer buffer
) (object pstring
))
112 (buffer-insert buffer object
)
113 (incf (marker-position (buffer-point buffer
)) (pstring-length object
)))
115 (defun buffer-delete (buf p length
)
116 "Deletes chars from point to point + n. If N is negative, deletes backwards."
118 (gap-move-to buf
(buffer-char-to-aref buf p
))
119 (let* ((new (max 0 (+ (buffer-gap-start buf
) length
)))
120 (capped-size (- (buffer-gap-start buf
) new
)))
121 (update-markers-del buf new capped-size
)
122 (record-delete new
(make-buffer-string new
(+ new capped-size
) t buf
))
123 (adjust-intervals-for-deletion buf new capped-size
)
124 (incf (buffer-gap-size buf
) capped-size
)
125 (setf (buffer-gap-start buf
) new
)))
127 (unless (>= p
(zv buf
))
128 ;; can't delete forward if we're at the end of the buffer.
129 (gap-move-to buf
(buffer-char-to-aref buf p
))
130 ;; Make sure the gap size doesn't grow beyond the buffer size.
131 (let ((capped-size (- (min (+ (gap-end buf
) length
)
132 (length (buffer-data buf
)))
134 (record-delete p
(make-buffer-string p
(+ p capped-size
) t buf
))
135 (incf (buffer-gap-size buf
) capped-size
)
136 (update-markers-del buf p capped-size
)
137 (adjust-intervals-for-deletion buf p capped-size
)))))
138 (setf (buffer-modified-p buf
) t
)
142 (defun buffer-erase (&optional
(buf (current-buffer)))
144 (record-delete (begv buf
) (make-buffer-string (begv buf
) (zv buf
) t buf
) buf
)
145 (adjust-intervals-for-deletion buf
0 (buffer-size buf
))
146 (update-markers-del buf
0 (buffer-size buf
))
147 ;; expand the gap to take up the whole buffer
148 (setf (buffer-gap-start buf
) 0
149 (buffer-gap-size buf
) (length (buffer-data buf
))
150 (marker-position (buffer-point buf
)) 0
151 (buffer-modified-p buf
) t
)
155 (defcommand erase-buffer
((&optional
(buffer (current-buffer))))
156 "Delete the entire contents of the current buffer.
157 Any narrowing restriction in effect (see `narrow-to-region') is removed,
158 so the buffer is truly empty after this."
159 (buffer-erase buffer
))