1 (declaim (optimize (debug 3)))
7 (defvar *buffer-list
* nil
8 "All buffers managed by lice. buffers are sorted from most recently
9 accessed to least. the CAR is the most recent buffer.")
11 (defvar *current-buffer
* nil
12 "When this buffer is non-nil, it contains the current buffer. Calls
13 to `current-buffer' return this buffer. Otherwise, `current-buffer'
14 returns the current frames's current window's buffer.
16 This variable should never be set using `setq' or `setf'. Bind it with
17 `let' for as long as it needs to be set.")
20 ((data :type string
:initarg
:data
:accessor pstring-data
)
21 (intervals :type
(or null interval
) :initform nil
:initarg
:intervals
:accessor intervals
))
22 (:documentation
"The lice string implementation."))
24 (defmethod print-object ((obj pstring
) stream
)
25 (print-unreadable-object (obj stream
:type t
:identity t
)
26 (format stream
"~s" (pstring-data obj
))))
28 (defun pstring-length (ps)
29 "Return the length of the string in PS"
30 (declare (type pstring ps
))
31 (length (pstring-data ps
)))
34 ((file :type
(or null pathname
) :initarg
:file
:accessor buffer-file
)
35 (name :type string
:initarg
:name
:accessor buffer-name
)
36 (point :type marker
:initarg
:point
:accessor buffer-point
)
37 (mark :type marker
:initarg
:mark
:accessor buffer-mark-marker
)
38 ;; A string containing the raw buffer
39 (data :type
(array character
1) :initarg
:data
:accessor buffer-data
)
40 (intervals :type
(or null interval
) :initform nil
:initarg
:intervals
:accessor intervals
)
41 (gap-start :type integer
:initarg
:gap-start
:accessor buffer-gap-start
)
42 (gap-size :type integer
:initarg
:gap-size
:accessor buffer-gap-size
)
44 (mode-line :type list
:initarg
:mode-line
:initform nil
:accessor buffer-mode-line
)
45 (mode-line-string :type string
:initform
"" :accessor buffer-mode-line-string
)
46 (modified :type boolean
:initform nil
:accessor buffer-modified
)
47 (read-only :type boolean
:initform nil
:accessor buffer-read-only
)
48 (tick :type integer
:initform
0 :accessor buffer-modified-tick
:documentation
49 "The buffer's tick counter. It is incremented for each change
51 (display-count :type integer
:initform
0 :accessor buffer-display-count
:documentation
52 "The buffer's display counter. It is incremented each time it
53 is displayed in a window.")
54 (display-time :type integer
:initform
0 :accessor buffer-display-time
:documentation
55 "The last time the buffer was switched to in a window.")
56 (major-mode :type major-mode
:initarg
:major-mode
:accessor buffer-major-mode
)
57 (markers :type list
:initform
'() :accessor buffer-markers
))
58 (:documentation
"A Buffer."))
60 (defmethod print-object ((obj buffer
) stream
)
61 (print-unreadable-object (obj stream
:type t
:identity t
)
62 (format stream
"~a" (buffer-name obj
))))
64 (define-condition args-out-of-range
(lice-condition)
65 () (:documentation
"Raised when some arguments (usually relating to a
66 buffer) are out of range."))
68 (define-condition beginning-of-buffer
(lice-condition)
69 () (:documentation
"Raised when it is an error that the point is at
70 the beginning of the buffer."))
72 (define-condition end-of-buffer
(lice-condition)
73 () (:documentation
"Raised when it is an error that the point is at
74 the end of the buffer."))
76 (define-condition buffer-read-only
(lice-condition)
77 () (:documentation
"Raised when there is an attempt to insert into a read-only buffer."))
79 (defun mark-marker (&optional
(buffer (current-buffer)))
80 "Return this buffer's mark, as a marker object.
81 Watch out! Moving this marker changes the mark position.
82 If you set the marker not to point anywhere, the buffer will have no mark."
83 ;; FIXME: marks can't be inactive ATM
84 (buffer-mark-marker buffer
))
87 ;;; buffer related conditions
89 ;;(define-condition end-of-buffer)
95 ((position :type integer
:initform
0 :accessor marker-position
)
96 (buffer :type
(or buffer null
) :initform nil
:accessor marker-buffer
))
97 (:documentation
"A Marker"))
99 (defmethod print-object ((obj marker
) stream
)
100 (print-unreadable-object (obj stream
:type t
:identity t
)
101 (format stream
"~a" (marker-position obj
))))
103 (defun copy-marker (marker)
104 "Return a new marker with the same point and buffer as MARKER."
105 (make-marker (marker-position marker
) (marker-buffer marker
)))
107 (defun make-marker (&optional position buffer
)
108 "Return a newly allocated marker which does not point anywhere."
109 (let ((m (make-instance 'marker
)))
110 (when (and position buffer
)
111 (set-marker m position buffer
))
114 (defun set-marker (marker position
&optional
(buffer (current-buffer)))
115 ;; TODO: make sure the position is within bounds
116 (setf (marker-position marker
) position
)
117 ;; remove the marker from its buffer, when appropriate
118 (when (and (marker-buffer marker
)
120 (not (eq (marker-buffer marker
) buffer
))))
121 (setf (buffer-markers (marker-buffer marker
))
122 (delete marker
(buffer-markers (marker-buffer marker
)) :key
#'weak-pointer-value
)))
123 ;; Update marker's buffer
124 (setf (marker-buffer marker
) buffer
)
125 ;; Put the marker in the new buffer's list (wrapped in a
126 ;; weak-pointer), when appropriate.
128 (push (make-weak-pointer marker
) (buffer-markers buffer
))))
130 (defun update-markers-del (buffer start size
)
131 ;; First get rid of stale markers
132 (purge-markers buffer
)
133 (dolist (wp (buffer-markers buffer
))
134 (let ((m (weak-pointer-value wp
)))
135 ;; paranoia, maybe the GC freed some stuff after the marker
138 ;; markers are before the marker-position.
139 (cond ((>= (marker-position m
) (+ start size
))
140 (decf (marker-position m
) size
))
141 ((> (marker-position m
) start
)
142 (setf (marker-position m
) start
)))))))
144 (defun update-markers-ins (buffer start size
)
145 ;; First get rid of stale markers
146 (purge-markers buffer
)
147 (dolist (wp (buffer-markers buffer
))
148 (let ((m (weak-pointer-value wp
)))
149 ;; markers are before the marker-position.
150 (when (and m
(> (marker-position m
) start
)
151 (incf (marker-position m
) size
))))))
153 (defun purge-markers (buffer)
154 "Remove GC'd markers."
155 (setf (buffer-markers buffer
)
156 (delete-if (lambda (m)
157 (multiple-value-bind (v c
) (weak-pointer-value m
)
159 (buffer-markers buffer
))))
164 (defun inc-buffer-tick (buffer)
165 "Increment the buffer's ticker."
166 (incf (buffer-modified-tick buffer
)))
168 ;;; Some wrappers around replace
170 (defun move-subseq-left (seq from end to
)
171 "Move the subseq between from and end to before TO, which is assumed to be
173 (replace seq seq
:start1
(+ to
(- end from
) 1) :start2 to
:end2 from
)
176 (defun move-subseq-right (seq from end to
)
177 "Move the subseq between from and end to before TO, which is assumed to be
179 (replace seq seq
:start1 from
:start2
(1+ end
) :end2 to
)
180 (+ from
(- to end
1)))
182 (defun move-subseq (seq from end to
)
183 "Destructively move the gap subseq starting at from and ending at
184 end, inclusive, to before TO."
186 (move-subseq-left seq from end to
)
187 (move-subseq-right seq from end to
)))
189 (defun fill-gap (buf)
190 "For debugging purposes. fill the gap with _'s."
191 (fill (buffer-data buf
) #\_
:start
(buffer-gap-start buf
) :end
(gap-end buf
)))
193 (defun gap-move-to (buf to
)
194 "A basic function to move the gap. TO is in aref coordinates and the
195 gap is positioned before TO.
198 (gap-move-to buffer 6)
200 (setf (buffer-gap-start buf
)
201 (move-subseq (buffer-data buf
) (buffer-gap-start buf
) (1- (gap-end buf
)) to
))
202 ;; for debugging purposes, we set the gap to _'s
205 (defun gap-move-to-point (buf)
206 "Move the gap to the point position in aref space.
213 (gap-move-to buf
(buffer-char-to-aref buf
(marker-position (buffer-point buf
)))))
215 ;; ;; Move the gap to the end of the vector
216 ;; (replace data data :start1 gap-start :start2 gap-end)
217 ;; ;; open a space for the gap
218 ;; (replace data data :start1 (+ to (buffer-gap-size buf)) :start2 to)
219 ;; (setf (buffer-gap-start buf) to)))
222 "The end of the gap. in aref space. gap-end is the first valid
224 (declare (type buffer buf
))
225 (+ (buffer-gap-start buf
) (buffer-gap-size buf
)))
227 ;; (defun gap-close (buf)
228 ;; "Move the gap to the end of the buffer."
229 ;; (let ((gap-start (buffer-gap-start buf))
230 ;; (gap-end (gap-end buf)))
231 ;; (setf (buffer-gap-start buf) (- (length (buffer-data buf)) (buffer-gap-size buf)))
232 ;; (replace (buffer-data buf) (buffer-data buf) :start1 gap-start :start2 gap-end)))
234 (defun grow-buffer-data (buf size
)
235 "Grow the buffer data array to be SIZE. SIZE must be larger than before."
236 ;; MOVITZ doesn't have adjust-array
237 ;; ;; #\_ is used for debugging to represent the gap
238 ;; (adjust-array (buffer-data buf) size :initial-element #\_ :fill-pointer t)
239 (let ((newbuf (make-array size
:initial-element
#\_
;; :fill-pointer t
240 :element-type
'character
)))
241 (replace newbuf
(buffer-data buf
))
242 (setf (buffer-data buf
) newbuf
)))
244 (defun gap-extend (buf size
)
245 "Extend the gap by SIZE characters."
246 (let ((new-size (+ (length (buffer-data buf
)) size
))
247 (old-end (gap-end buf
))
248 (old-size (buffer-size buf
))
249 (data (buffer-data buf
)))
250 (setf data
(grow-buffer-data buf new-size
))
251 (incf (buffer-gap-size buf
) size
)
252 (unless (= (buffer-gap-start buf
) old-size
)
254 :start1
(gap-end buf
)
256 ;; for debugging, mark the gap
259 (defun buffer-size (buf)
260 "Return the length of the buffer not including the gap."
261 (declare (type buffer buf
))
262 (- (length (buffer-data buf
))
263 (buffer-gap-size buf
)))
265 (defun buffer-min (buf)
266 "The beginning of the buffer in char space."
267 (declare (type buffer buf
))
270 (defun buffer-max (buf)
271 "The end of the buffer in char space."
272 (declare (type buffer buf
))
275 (defun begv (&optional
(buf (current-buffer)))
276 "Position of beginning of accessible range of buffer."
277 ;; TODO: handle buffer narrowing
280 (defun zv (&optional
(buf (current-buffer)))
281 "Position of end of accessible range of buffer."
282 ;; TODO: handle buffer narrowing
285 (defun point (&optional
(buffer (current-buffer)))
286 "Return the point in the current buffer."
287 (marker-position (buffer-point buffer
)))
289 (defun point-marker (&optional
(buffer (current-buffer)))
290 "Return value of point, as a marker object."
291 (buffer-point buffer
))
293 (defun point-min (&optional
(buffer (current-buffer)))
294 "Return the minimum permissible value of point in the current buffer."
295 (declare (ignore buffer
))
298 (defun point-max (&optional
(buffer (current-buffer)))
299 "Return the maximum permissible value of point in the current buffer."
300 (buffer-size buffer
))
302 (defun goto-char (position &optional
(buffer (current-buffer)))
303 "Set point to POSITION, a number."
304 (when (and (>= position
(point-min buffer
))
305 (<= position
(point-max buffer
)))
306 (setf (marker-position (buffer-point buffer
)) position
)))
308 ;; (defun buffer-char-before-point (buf p)
309 ;; "The character at the point P in buffer BUF. P is in char space."
310 ;; (declare (type buffer buf)
312 ;; (let ((aref (buffer-char-to-aref buf p)))
313 ;; (when (< aref (length (buffer-data buf)))
314 ;; (aref (buffer-data buf) aref))))
316 (defun buffer-char-after (buf p
)
317 "The character at the point P in buffer BUF. P is in char space."
318 (declare (type buffer buf
)
320 (let ((aref (buffer-char-to-aref buf p
)))
321 (when (and (>= aref
0)
322 (< aref
(length (buffer-data buf
))))
323 (aref (buffer-data buf
) aref
))))
325 (defun buffer-char-before (buf p
)
326 (buffer-char-after buf
(1- p
)))
328 (defun char-after (&optional
(pos (point)))
329 "Return character in current buffer at position POS.
330 ***POS is an integer or a marker.
331 ***If POS is out of range, the value is nil."
332 (buffer-char-after (current-buffer) pos
))
334 (defun char-before (&optional
(pos (point)))
335 "Return character in current buffer preceding position POS.
336 ***POS is an integer or a marker.
337 ***If POS is out of range, the value is nil."
338 (char-after (1- pos
)))
340 (defun buffer-aref-to-char (buf idx
)
341 "Translate the index into the buffer data to the index excluding the gap."
342 (declare (type buffer buf
)
344 (if (>= idx
(gap-end buf
))
345 (- idx
(buffer-gap-size buf
))
348 (defun buffer-char-to-aref (buf p
)
350 (declare (type buffer buf
)
352 (if (>= p
(buffer-gap-start buf
))
353 (+ p
(buffer-gap-size buf
))
356 (defun buffer-point-aref (buf)
357 "Return the buffer point in aref coordinates."
358 (buffer-char-to-aref buf
(point buf
)))
360 (defun string-to-vector (s)
361 "Return a resizable vector containing the elements of the string s."
363 (make-array (length s
)
365 :element-type
'character
369 (defgeneric buffer-insert
(buffer object
)
370 (:documentation
"Insert OBJECT into BUFFER at the current point."))
372 (defmethod buffer-insert :after
((buf buffer
) object
)
373 "Any object insertion modifies the buffer."
374 (setf (buffer-modified buf
) t
))
376 (defmethod buffer-insert ((buf buffer
) (char character
))
377 "Insert a single character into buffer before point."
378 ;; Resize the gap if needed
379 (if (<= (buffer-gap-size buf
) 1)
380 (gap-extend buf
100))
381 ;; Move the gap to the point
382 (unless (= (point buf
) (buffer-gap-start buf
))
383 (gap-move-to buf
(buffer-point-aref buf
)))
384 (update-markers-ins buf
(point buf
) 1)
386 (setf (aref (buffer-data buf
) (buffer-gap-start buf
)) char
)
387 ;; move the gap forward
388 (incf (buffer-gap-start buf
))
389 (decf (buffer-gap-size buf
))
390 ;; expand the buffer intervals
391 (offset-intervals buf
(point buf
) 1))
393 (defmethod buffer-insert ((buf buffer
) (string string
))
395 (when (<= (buffer-gap-size buf
) (length string
))
396 (gap-extend buf
(+ (length string
) 100)))
397 ;; move the gap to the point
398 (unless (= (point buf
) (buffer-gap-start buf
))
399 (gap-move-to buf
(buffer-point-aref buf
)))
400 (update-markers-ins buf
(point buf
) (length string
))
402 (replace (buffer-data buf
) string
:start1
(buffer-gap-start buf
))
403 (incf (buffer-gap-start buf
) (length string
))
404 (decf (buffer-gap-size buf
) (length string
))
405 ;; expand the buffer intervals
406 (offset-intervals buf
(point buf
) (length string
)))
408 (defmethod buffer-insert ((buf buffer
) (string pstring
))
410 (buffer-insert buf
(pstring-data string
))
412 (graft-intervals-into-buffer (intervals string
)
414 (pstring-length string
)
418 (defgeneric insert-move-point
(buffer object
)
419 (:documentation
"Insert OBJECT into BUFFER at the current point. Move the point
420 forward by its length."))
422 (defmethod insert-move-point ((buffer buffer
) (object character
))
423 (buffer-insert buffer object
)
424 (incf (marker-position (buffer-point buffer
))))
426 (defmethod insert-move-point ((buffer buffer
) (object string
))
427 (buffer-insert buffer object
)
428 (incf (marker-position (buffer-point buffer
)) (length object
)))
430 (defmethod insert-move-point ((buffer buffer
) (object pstring
))
431 (buffer-insert buffer object
)
432 (incf (marker-position (buffer-point buffer
)) (pstring-length object
)))
434 (defun insert (&rest objects
)
435 "Insert the arguments, either strings or characters, at point.
436 Point and before-insertion markers move forward to end up after the
437 inserted text. Any other markers at the point of insertion remain
440 (insert-move-point (current-buffer) o
)))
442 (defun buffer-delete (buf p length
)
443 "Deletes chars from point to point + n. If N is negative, deletes backwards."
445 (gap-move-to buf
(buffer-char-to-aref buf p
))
446 (let* ((new (max 0 (+ (buffer-gap-start buf
) length
)))
447 (capped-size (- (buffer-gap-start buf
) new
)))
448 (update-markers-del buf new capped-size
)
449 (adjust-intervals-for-deletion buf new capped-size
)
450 (incf (buffer-gap-size buf
) capped-size
)
451 (setf (buffer-gap-start buf
) new
)))
453 (unless (>= p
(zv buf
))
454 ;; can't delete forward if we're at the end of the buffer.
455 (gap-move-to buf
(buffer-char-to-aref buf p
))
456 ;; Make sure the gap size doesn't grow beyond the buffer size.
457 (let ((capped-size (- (min (+ (gap-end buf
) length
)
458 (length (buffer-data buf
)))
460 (incf (buffer-gap-size buf
) capped-size
)
461 (update-markers-del buf p capped-size
)
462 (adjust-intervals-for-deletion buf p capped-size
)))))
463 (setf (buffer-modified buf
) t
)
467 (defun buffer-erase (&optional
(buf (current-buffer)))
469 (adjust-intervals-for-deletion buf
0 (buffer-size buf
))
470 (update-markers-del buf
0 (buffer-size buf
))
471 ;; expand the gap to take up the whole buffer
472 (setf (buffer-gap-start buf
) 0
473 (buffer-gap-size buf
) (length (buffer-data buf
))
474 (marker-position (buffer-point buf
)) 0
475 (buffer-modified buf
) t
)
479 (defun buffer-scan-newline (buf start limit count
)
480 "Search BUF for COUNT newlines with a limiting point at LIMIT,
481 starting at START. Returns the point of the last newline or limit and
482 number of newlines found. START and LIMIT are inclusive."
483 (declare (type buffer buf
)
484 (type integer start limit count
))
485 (labels ((buffer-scan-bk (buf start limit count
)
486 "count is always >=0. start >= limit."
487 (let* ((start-aref (buffer-char-to-aref buf start
))
488 (limit-aref (buffer-char-to-aref buf limit
))
489 (ceiling (if (>= start-aref
(gap-end buf
))
493 ;; :END is not inclusive but START is.
494 (start (1+ start-aref
))
497 ;; Always search at least once
498 (setf p
(position #\Newline
(buffer-data buf
)
499 :start ceiling
:end start
:from-end t
))
502 ;; Move start. Note that start isn't set to (1+ p)
503 ;; because we don't want to search p again.
507 ;; Have we found enough newlines?
509 (return-from buffer-scan-bk
(values (buffer-aref-to-char buf p
)
511 ;; Check if we've searched up to the limit
512 (if (= ceiling limit-aref
)
513 (return-from buffer-scan-bk
(values limit i
))
514 ;; if not, skip past the gap
516 (setf ceiling limit-aref
)
517 (setf start
(buffer-gap-start buf
))))))))
518 (buffer-scan-fw (buf start limit count
)
519 "count is always >=0. start >= limit."
520 (let* ((start-aref (buffer-char-to-aref buf start
))
521 (limit-aref (1+ (buffer-char-to-aref buf limit
)))
522 (ceiling (if (< start
(buffer-gap-start buf
))
523 (buffer-gap-start buf
)
529 ;; Always search at least once
530 (setf p
(position #\Newline
(buffer-data buf
) :start start
:end ceiling
))
533 ;; Move start. We don't want to search p again, thus the 1+.
537 ;; Have we found enough newlines?
539 (return-from buffer-scan-fw
(values (buffer-aref-to-char buf p
)
541 ;; Check if we've searched up to the limit
542 (if (= ceiling limit-aref
)
543 (return-from buffer-scan-fw
(values limit i
))
544 ;; if not, skip past the gap
546 (setf ceiling limit-aref
)
547 (setf start
(gap-end buf
)))))))))
548 ;; make sure start and limit are within the bounds
549 (setf start
(max 0 (min start
(1- (buffer-size buf
))))
550 limit
(max 0 (min limit
(1- (buffer-size buf
)))))
551 ;; the search always fails on an empty buffer
552 (when (= (buffer-size buf
) 0)
553 (return-from buffer-scan-newline
(values limit
0)))
555 (dformat +debug-vv
+ "scan-fw ~a ~a ~a~%" start limit count
)
556 (buffer-scan-fw buf start limit count
))
558 (dformat +debug-vv
+ "scan-bk ~a ~a ~a~%" start limit count
)
559 (buffer-scan-bk buf start limit
(abs count
)))
560 ;; 0 means the newline before the beginning of the current
561 ;; line. We need to handle the case where we are on a newline.
563 (dformat +debug-vv
+ "scan-0 ~a ~a ~a~%" start limit count
)
564 (if (char= (buffer-char-after buf start
) #\Newline
)
565 (buffer-scan-bk buf start limit
2)
566 (buffer-scan-bk buf start limit
1))))))
570 ;; (defparameter +scratch-buffer+ ";; This buffer is for notes you don't want to save, and for Lisp evaluation.
571 ;; ;; If you want to create a file, visit that file with C-x C-f,
572 ;; ;; then enter the text in that file's own buffer.")
574 ;; (defparameter +other-buf+
575 ;; "678901234567890 abcdefghijklmnopqrstuvwxyz
576 ;; 1 abcdefghijklmnopqrstuvwxyz
577 ;; 2 abcdefghijklmnopqrstuvwxyz
578 ;; 3 abcdefghijklmnopqrstuvwxyz
579 ;; 4 abcdefghijklmnopqrstuvwxyz
580 ;; 5 abcdefghijklmnopqrstuvwxyz
581 ;; 6 abcdefghijklmnopqrstuvwxyz
582 ;; 7 abcdefghijklmnopqrstuvwxyz
583 ;; 8 abcdefghijklmnopqrstuvwxyz")
585 ;; (defun buffer-read-from-stream (buffer stream)
586 ;; "Read the contents of stream until EOF, putting it in buffer-data"
587 ;; (loop for c = (read-char stream nil nil)
589 ;; do (vector-push-extend c (buffer-data buffer))))
591 ;; (defun buffer-read-from-file (buffer file)
592 ;; (with-open-file (s file :direction :input)
593 ;; (buffer-read-from-stream buffer s)))
597 ;; FIXME: this is a parameter for debugging
598 ;; FIXME: be more emacs-like or make it better so we don't just have
599 ;; lambda functions that process data and return a string.
600 (defparameter *mode-line-format
* (list "--:" ;; fake it for hype
603 ;; FIXME: add read-only stuff
604 (if (buffer-modified buffer
)
606 (if (buffer-modified buffer
)
610 (format nil
"~12,,,a" (buffer-name buffer
)))
614 (major-mode-name (buffer-major-mode buffer
)))))
615 "The default mode line format.")
617 (defgeneric mode-line-format-elem
(buffer elem
)
618 (:documentation
"Given the element found in the buffer mode-line,
619 return a string that will be printed in the mode-line."))
621 (defmethod mode-line-format-elem ((b buffer
) (elem string
))
622 "just return the string."
626 (defmethod mode-line-format-elem ((b buffer
) (elem function
))
627 "Call the function. It is expected to return a string."
630 (defmethod mode-line-format-elem ((b buffer
) (elem symbol
))
631 "elem is a symbol, so print its value."
634 (defun update-mode-line (buffer)
635 "Given the buffer, refresh its mode-line string."
636 (setf (buffer-mode-line-string buffer
)
637 (format nil
"~{~a~}" (mapcar (lambda (elem)
638 (mode-line-format-elem buffer elem
))
639 (buffer-mode-line buffer
)))))
641 (defun truncate-mode-line (buffer len
)
642 "return the buffers mode-line trunctated to len. If the mode-line is
643 shorter than len, it will be padded with -'s."
644 (let ((s (make-array len
:element-type
'character
:initial-element
#\-
)))
645 (replace s
(buffer-mode-line-string buffer
))))
647 ;;; Buffer query/creation
649 (defgeneric get-buffer
(name)
650 (:documentation
"Return the buffer named NAME. If there is no live
651 buffer named NAME, return NIL."))
653 (defmethod get-buffer ((name string
))
654 (find name
*buffer-list
* :key
#'buffer-name
:test
#'string
=))
656 (defmethod get-buffer ((buffer buffer
))
657 (find buffer
*buffer-list
*))
659 (defgeneric get-buffer-create
(name)
660 (:documentation
"Return the buffer named NAME, or create such a buffer and return it.
661 A new buffer is created if there is no live buffer named NAME.
662 If NAME starts with a space, the new buffer does not keep undo information.
663 If NAME is a buffer instead of a string, then it is the value returned.
664 The value is never nil."))
666 (defmethod get-buffer-create ((name string
))
670 (when (zerop (length name
))
671 (error "Empty string for buffer name is not allowed"))
672 (let ((b (make-instance 'buffer
676 ;; Currently a buffer has to have a gap
677 ;; of at least size 1.
678 :data
(string-to-vector "_")
681 :mode-line
*mode-line-format
*
683 :major-mode fundamental-mode
)))
684 (set-marker (buffer-point b
) 0 b
)
685 (set-marker (mark-marker b
) 0 b
)
686 (push b
*buffer-list
*)
689 (defmethod get-buffer-create ((buffer buffer
))
694 (defun make-default-buffers ()
695 "Called on startup. Create the default buffers, putting them in
697 (let ((messages (get-buffer-create "*messages*"))
698 (scratch (get-buffer-create "*scratch*")))
699 (buffer-insert scratch
";; This buffer is for notes you don't want to save, and for Lisp evaluation.
700 ;; If you want to create a file, visit that file with C-x C-f,
701 ;; then enter the text in that file's own buffer.")
702 ;; FIXME: is this a hack?
703 (setf (buffer-modified scratch
) nil
)
704 (goto-char (point-min scratch
) scratch
)))
708 (defun generate-new-buffer-name (name &optional ignore
)
709 "Return a string that is the name of no existing buffer based on NAME.
710 If there is no live buffer named NAME, then return NAME.
711 Otherwise modify name by appending `<NUMBER>', incrementing NUMBER
712 until an unused name is found, and then return that name.
713 Optional second argument IGNORE specifies a name that is okay to use
714 (if it is in the sequence to be tried)
715 even if a buffer with that name exists."
716 (declare (type string name
)
717 (type (or string null
) ignore
))
718 (or (unless (get-buffer name
)
720 (loop for count from
1
721 ;; FIXME: there's gotta be a way to do this where s isn't
724 do
(setf s
(format nil
"~a<~d>" name count
))
728 unless
(get-buffer s
)
731 (defmacro with-current-buffer
(buffer &body body
)
732 "Execute the forms in BODY with BUFFER as the current buffer.
733 The value returned is the value of the last form in BODY.
734 See also `with-temp-buffer'."
735 `(let ((*current-buffer
* ,buffer
))
738 (defmacro with-temp-buffer
(&body body
)
739 "Create a temporary buffer, and evaluate BODY there like `progn'.
740 See also `with-temp-file'."
741 (let ((temp-buffer (gensym "TEMP-BUFFER")))
742 `(let ((,temp-buffer
(get-buffer-create (generate-new-buffer-name "*temp*"))))
744 (with-current-buffer ,temp-buffer
746 (and (get-buffer ,temp-buffer
)
747 (kill-buffer ,temp-buffer
))))))
749 (defun bring-buffer-to-front (buf)
750 "Put buf at the front of *buffer-list*. Assumes BUF is in
752 (setf *buffer-list
* (delete buf
*buffer-list
*))
753 (push buf
*buffer-list
*))
755 (defun other-buffer (&optional
(buffer (current-buffer)) visible-ok frame
)
756 "Return most recently selected buffer other than BUFFER.
757 Buffers not visible in windows are preferred to visible buffers,
758 unless optional second argument VISIBLE-OK is non-nil.
759 If the optional third argument FRAME is non-nil, use that frame's
760 buffer list instead of the selected frame's buffer list.
761 If no other buffer exists, the buffer `*scratch*' is returned.
762 If BUFFER is omitted or nil, some interesting buffer is returned."
763 ;; TODO: honour FRAME argument
765 (match (loop for b in
*buffer-list
*
766 unless
(or (eq b buffer
)
767 (char= (char (buffer-name b
) 0) #\Space
))
768 if
(and (not visible-ok
)
769 (get-buffer-window b
))
774 (get-buffer-create "*scratch*"))))
776 (defun mark (&optional force
(buffer (current-buffer)))
777 "Return BUFFER's mark value as integer; error if mark inactive.
778 If optional argument FORCE is non-nil, access the mark value
779 even if the mark is not currently active, and return nil
780 if there is no mark at all."
781 ;; FIXME: marks can't be inactive ATM
782 (marker-position (mark-marker buffer
)))
784 (defun validate-region (start end
&optional
(buffer (current-buffer)))
785 "Return a value pair of start and end for buffer. the 1st value
786 returned will always be <= the second. May raise an args out of range
789 If START or END are marks, their positions will be used."
790 (when (typep start
'marker
)
791 (setf start
(marker-position start
)))
792 (when (typep end
'marker
)
793 (setf end
(marker-position end
)))
795 ;; MOVITZ doesn't have psetf
802 (when (or (< start
(buffer-min buffer
))
803 (> end
(buffer-max buffer
)))
804 (signal 'args-out-of-range
))
807 (defun eobp (&optional
(buffer (current-buffer)))
808 "Return T when the point is at the end of the buffer."
809 (= (buffer-max buffer
) (point)))
811 (defun bobp (&optional
(buffer (current-buffer)))
812 "Return T when the point is at the beginning of the buffer."
813 (= (buffer-min buffer
) (point)))
815 (defun set-buffer (buffer)
816 "Make the buffer BUFFER current for editing operations.
817 BUFFER may be a buffer or the name of an existing buffer.
818 See also `save-excursion' when you want to make a buffer current temporarily.
819 This function does not display the buffer, so its effect ends
820 when the current command terminates.
821 Use `switch-to-buffer' or `pop-to-buffer' to switch buffers permanently."
822 (setf buffer
(get-buffer buffer
))
824 (setf *current-buffer
* buffer
)
825 (error "No buffer named ~s" buffer
)))
827 (defun record-buffer (buffer)
828 "**Move the assoc for buffer BUF to the front of buffer-alist.
829 Since we do this each time BUF is selected visibly, the more recently
830 selected buffers are always closer to the front of the list. This
831 means that other_buffer is more likely to choose a relevant buffer."
832 (setf *buffer-list
* (delete buffer
*buffer-list
* :test
#'eq
))
833 (push buffer
*buffer-list
*))
835 (defun barf-if-buffer-read-only ()
836 "Signal a `buffer-read-only' error if the current buffer is read-only."
837 (when (buffer-read-only (current-buffer))
838 (signal 'buffer-read-only
)))
840 (defun bufferp (object)
841 "Return t if object is an editor buffer."
842 (typep object
'buffer
))
844 (provide :lice-0.1
/buffer
)