buffer.lisp

   1 (declaim (optimize (debug 3)))
   2
   3 (in-package :lice)
   4
   5 (defconstant +beg+ 0)
   6
   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.")
  10
  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.
  15
  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.")
  18
  19 (defclass pstring ()
  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."))
  23
  24 (defmethod print-object ((obj pstring) stream)
  25   (print-unreadable-object (obj stream :type t :identity t)
  26     (format stream "~s" (pstring-data obj))))
  27
  28 (defun pstring-length (ps)
  29   "Return the length of the string in PS"
  30   (declare (type pstring ps))
  31   (length (pstring-data ps)))
  32
  33 (defclass buffer ()
  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)
  43    ;; mode-line
  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
  50 in text.")
  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    (locals-variables :type hash-table :initform (make-hash-table) :accessor buffer-local-variables)
  59    (locals :type hash-table :initform (make-hash-table) :accessor buffer-locals))
  60   (:documentation "A Buffer."))
  61
  62 (defmethod print-object ((obj buffer) stream)
  63   (print-unreadable-object (obj stream :type t :identity t)
  64     (format stream "~a" (buffer-name obj))))
  65
  66 (define-condition args-out-of-range (lice-condition)
  67   () (:documentation "Raised when some arguments (usually relating to a
  68 buffer) are out of range."))
  69
  70 (define-condition beginning-of-buffer (lice-condition)
  71   () (:documentation "Raised when it is an error that the point is at
  72 the beginning of the buffer."))
  73
  74 (define-condition end-of-buffer (lice-condition)
  75   () (:documentation "Raised when it is an error that the point is at
  76 the end of the buffer."))
  77
  78 (define-condition buffer-read-only (lice-condition)
  79   () (:documentation "Raised when there is an attempt to insert into a read-only buffer."))
  80
  81 (defun mark-marker (&optional (buffer (current-buffer)))
  82   "Return this buffer's mark, as a marker object.
  83 Watch out!  Moving this marker changes the mark position.
  84 If you set the marker not to point anywhere, the buffer will have no mark."
  85   ;; FIXME: marks can't be inactive ATM
  86   (buffer-mark-marker buffer))
  87
  88 \f
  89 ;;; buffer locals
  90
  91 (defstruct buffer-local-binding
  92   symbol value doc-string)
  93
  94 (defvar *global-buffer-locals* (make-hash-table)
  95   "The default values of buffer locals and a hash table containing all possible buffer locals")
  96
  97 (defun make-buffer-local (symbol default-value &optional doc-string)
  98   (unless (gethash symbol *global-buffer-locals*)
  99     (setf (gethash symbol *global-buffer-locals*)
 100           (make-buffer-local-binding :symbol symbol
 101                                      :value default-value
 102                                      :doc-string doc-string))))
 103
 104 (defmacro define-buffer-local (symbol default-value &optional doc-string)
 105   "buffer locals are data hooks you can use to store values per
 106 buffer. Use them when building minor and major modes. You
 107 generally want to define them with this so you can create a
 108 docstring for them. there is also `make-buffer-local'."
 109   `(make-buffer-local ,symbol ,default-value ,doc-string))
 110
 111 (defun (setf buffer-local) (symbol value)
 112   "Set the value of the buffer local in the current buffer."
 113   ;; FIXME: should we implicitely make a global one if it doesn't exist already?
 114   (setf (gethash symbol (buffer-locals *current-buffer*)) value))
 115
 116 (defun buffer-local (symbol)
 117   "Return the value of the buffer local symbol. If none exists
 118 for the current buffer then use the global one. If that doesn't
 119 exist, return nil."
 120   (multiple-value-bind (v b) (gethash symbol (buffer-locals *current-buffer*))
 121     (if b
 122         v
 123         (gethash symbol *global-buffer-locals*))))
 124
 125 \f
 126 ;;; buffer related conditions
 127
 128 ;;(define-condition end-of-buffer)
 129
 130 \f
 131 ;;; Markers
 132
 133 (defclass marker ()
 134   ((position :type integer :initform 0 :accessor marker-position)
 135    (buffer :type (or buffer null) :initform nil :accessor marker-buffer))
 136   (:documentation "A Marker"))
 137
 138 (defmethod print-object ((obj marker) stream)
 139   (print-unreadable-object (obj stream :type t :identity t)
 140     (format stream "~a" (marker-position obj))))
 141
 142 (defun copy-marker (marker)
 143   "Return a new marker with the same point and buffer as MARKER."
 144   (make-marker (marker-position marker) (marker-buffer marker)))
 145
 146 (defun make-marker (&optional position buffer)
 147   "Return a newly allocated marker which does not point anywhere."
 148   (let ((m (make-instance 'marker)))
 149     (when (and position buffer)
 150       (set-marker m position buffer))
 151     m))
 152
 153 (defun set-marker (marker position &optional (buffer (current-buffer)))
 154   ;; TODO: make sure the position is within bounds
 155   (setf (marker-position marker) position)
 156   ;; remove the marker from its buffer, when appropriate
 157   (when (and (marker-buffer marker)
 158              (or (null buffer)
 159                  (not (eq (marker-buffer marker) buffer))))
 160     (setf (buffer-markers (marker-buffer marker))
 161             (delete marker (buffer-markers (marker-buffer marker)) :key #'weak-pointer-value)))
 162   ;; Update marker's buffer
 163   (setf (marker-buffer marker) buffer)
 164   ;; Put the marker in the new buffer's list (wrapped in a
 165   ;; weak-pointer), when appropriate.
 166   (when buffer
 167     (push (make-weak-pointer marker) (buffer-markers buffer))))
 168
 169 (defun update-markers-del (buffer start size)
 170   ;; First get rid of stale markers
 171   (purge-markers buffer)
 172   (dolist (wp (buffer-markers buffer))
 173     (let ((m (weak-pointer-value wp)))
 174       ;; paranoia, maybe the GC freed some stuff after the marker
 175       ;; purge.
 176       (when m
 177         ;; markers are before the marker-position.
 178         (cond ((>= (marker-position m) (+ start size))
 179                (decf (marker-position m) size))
 180               ((> (marker-position m) start)
 181                (setf (marker-position m) start)))))))
 182
 183 (defun update-markers-ins (buffer start size)
 184   ;; First get rid of stale markers
 185   (purge-markers buffer)
 186   (dolist (wp (buffer-markers buffer))
 187     (let ((m (weak-pointer-value wp)))
 188       ;; markers are before the marker-position.
 189       (when (and m (> (marker-position m) start)
 190                  (incf (marker-position m) size))))))
 191
 192 (defun purge-markers (buffer)
 193   "Remove GC'd markers."
 194   (setf (buffer-markers buffer)
 195         (delete-if (lambda (m)
 196                      (multiple-value-bind (v c) (weak-pointer-value m)
 197                        (declare (ignore v))
 198                        (not c)))
 199                    (buffer-markers buffer))))
 200
 201 \f
 202 ;;;
 203
 204 (defun inc-buffer-tick (buffer)
 205   "Increment the buffer's ticker."
 206   (incf (buffer-modified-tick buffer)))
 207
 208 ;;; Some wrappers around replace
 209
 210 (defun move-subseq-left (seq from end to)
 211   "Move the subseq between from and end to before TO, which is assumed to be
 212 left of FROM."
 213   (replace seq seq :start1 (+ to (- end from) 1) :start2 to :end2 from)
 214   to)
 215
 216 (defun move-subseq-right (seq from end to)
 217   "Move the subseq between from and end to before TO, which is assumed to be
 218 right of FROM."
 219   (replace seq seq :start1 from :start2 (1+ end) :end2 to)
 220   (+ from (- to end 1)))
 221
 222 (defun move-subseq (seq from end to)
 223   "Destructively move the gap subseq starting at from and ending at
 224 end, inclusive, to before TO."
 225   (if (< to from)
 226       (move-subseq-left seq from end to)
 227     (move-subseq-right seq from end to)))
 228
 229 (defun fill-gap (buf)
 230   "For debugging purposes. fill the gap with _'s."
 231   (fill (buffer-data buf) #\_ :start (buffer-gap-start buf) :end (gap-end buf)))
 232
 233 (defun gap-move-to (buf to)
 234   "A basic function to move the gap. TO is in aref coordinates and the
 235 gap is positioned before TO.
 236
 237  BUFFER: ABC__DEF
 238  (gap-move-to buffer 6)
 239  BUFFER: ABCD__EF"
 240   (setf (buffer-gap-start buf)
 241         (move-subseq (buffer-data buf) (buffer-gap-start buf) (1- (gap-end buf)) to))
 242   ;; for debugging purposes, we set the gap to _'s
 243   (fill-gap buf))
 244
 245 (defun gap-move-to-point (buf)
 246   "Move the gap to the point position in aref space.
 247 ABCD___EF
 248  ^
 249 =>
 250 A___BCDEF
 251     ^
 252 "
 253   (gap-move-to buf (buffer-char-to-aref buf (marker-position (buffer-point buf)))))
 254
 255 ;;     ;; Move the gap to the end of the vector
 256 ;;     (replace data data :start1 gap-start :start2 gap-end)
 257 ;;     ;; open a space for the gap
 258 ;;     (replace data data :start1 (+ to (buffer-gap-size buf)) :start2 to)
 259 ;;     (setf (buffer-gap-start buf) to)))
 260
 261 (defun gap-end (buf)
 262   "The end of the gap. in aref space. gap-end is the first valid
 263 buffer character."
 264   (declare (type buffer buf))
 265   (+ (buffer-gap-start buf) (buffer-gap-size buf)))
 266
 267 ;; (defun gap-close (buf)
 268 ;;   "Move the gap to the end of the buffer."
 269 ;;   (let ((gap-start (buffer-gap-start buf))
 270 ;;      (gap-end (gap-end buf)))
 271 ;;     (setf (buffer-gap-start buf) (- (length (buffer-data buf)) (buffer-gap-size buf)))
 272 ;;     (replace (buffer-data buf) (buffer-data buf) :start1 gap-start :start2 gap-end)))
 273
 274 (defun grow-buffer-data (buf size)
 275   "Grow the buffer data array to be SIZE. SIZE must be larger than before."
 276   ;; MOVITZ doesn't have adjust-array
 277   ;; ;; #\_ is used for debugging to represent the gap
 278   ;; (adjust-array (buffer-data buf) size :initial-element #\_ :fill-pointer t)
 279   (let ((newbuf (make-array size :initial-element #\_;;  :fill-pointer t
 280                             :element-type 'character)))
 281     (replace newbuf (buffer-data buf))
 282     (setf (buffer-data buf) newbuf)))
 283
 284 (defun gap-extend (buf size)
 285   "Extend the gap by SIZE characters."
 286   (let ((new-size (+ (length (buffer-data buf)) size))
 287         (old-end (gap-end buf))
 288         (old-size (buffer-size buf))
 289         (data (buffer-data buf)))
 290     (setf data (grow-buffer-data buf new-size))
 291     (incf (buffer-gap-size buf) size)
 292     (unless (= (buffer-gap-start buf) old-size)
 293       (replace data data
 294                :start1 (gap-end buf)
 295                :start2 old-end))
 296     ;; for debugging, mark the gap
 297     (fill-gap buf)))
 298
 299 (defun buffer-size (buf)
 300   "Return the length of the buffer not including the gap."
 301   (declare (type buffer buf))
 302   (- (length (buffer-data buf))
 303      (buffer-gap-size buf)))
 304
 305 (defun buffer-min (buf)
 306   "The beginning of the buffer in char space."
 307   (declare (type buffer buf)
 308            (ignore buf))
 309   0)
 310
 311 (defun buffer-max (buf)
 312   "The end of the buffer in char space."
 313   (declare (type buffer buf))
 314   (buffer-size buf))
 315
 316 (defun begv (&optional (buf (current-buffer)))
 317   "Position of beginning of accessible range of buffer."
 318   ;; TODO: handle buffer narrowing
 319   (buffer-min buf))
 320
 321 (defun zv (&optional (buf (current-buffer)))
 322   "Position of end of accessible range of buffer."
 323   ;; TODO: handle buffer narrowing
 324   (buffer-max buf))
 325
 326 (defun point (&optional (buffer (current-buffer)))
 327   "Return the point in the current buffer."
 328   (marker-position (buffer-point buffer)))
 329
 330 (defun point-marker (&optional (buffer (current-buffer)))
 331   "Return value of point, as a marker object."
 332   (buffer-point buffer))
 333
 334 (defun point-min (&optional (buffer (current-buffer)))
 335   "Return the minimum permissible value of point in the current buffer."
 336   (declare (ignore buffer))
 337   0)
 338
 339 (defun point-max (&optional (buffer (current-buffer)))
 340   "Return the maximum permissible value of point in the current buffer."
 341   (buffer-size buffer))
 342
 343 (defun goto-char (position &optional (buffer (current-buffer)))
 344   "Set point to POSITION, a number."
 345   (when (and (>= position (point-min buffer))
 346              (<= position (point-max buffer)))
 347     (setf (marker-position (buffer-point buffer)) position)))
 348
 349 ;; (defun buffer-char-before-point (buf p)
 350 ;;   "The character at the point P in buffer BUF. P is in char space."
 351 ;;   (declare (type buffer buf)
 352 ;;         (type integer p))
 353 ;;   (let ((aref (buffer-char-to-aref buf p)))
 354 ;;       (when (< aref (length (buffer-data buf)))
 355 ;;      (aref (buffer-data buf) aref))))
 356
 357 (defun buffer-char-after (buf p)
 358   "The character at the point P in buffer BUF. P is in char space."
 359   (declare (type buffer buf)
 360            (type integer p))
 361   (let ((aref (buffer-char-to-aref buf p)))
 362       (when (and (>= aref 0)
 363                  (< aref (length (buffer-data buf))))
 364         (aref (buffer-data buf) aref))))
 365
 366 (defun buffer-char-before (buf p)
 367   (buffer-char-after buf (1- p)))
 368
 369 (defun char-after (&optional (pos (point)))
 370   "Return character in current buffer at position POS.
 371 ***POS is an integer or a marker.
 372 ***If POS is out of range, the value is nil."
 373   (buffer-char-after (current-buffer) pos))
 374
 375 (defun char-before (&optional (pos (point)))
 376   "Return character in current buffer preceding position POS.
 377 ***POS is an integer or a marker.
 378 ***If POS is out of range, the value is nil."
 379   (char-after (1- pos)))
 380
 381 (defun buffer-aref-to-char (buf idx)
 382   "Translate the index into the buffer data to the index excluding the gap."
 383   (declare (type buffer buf)
 384            (type integer idx))
 385   (if (>= idx (gap-end buf))
 386       (- idx (buffer-gap-size buf))
 387     idx))
 388
 389 (defun buffer-char-to-aref (buf p)
 390   ""
 391   (declare (type buffer buf)
 392            (type integer p))
 393   (if (>= p (buffer-gap-start buf))
 394       (+ p (buffer-gap-size buf))
 395     p))
 396
 397 (defun buffer-point-aref (buf)
 398   "Return the buffer point in aref coordinates."
 399   (buffer-char-to-aref buf (point buf)))
 400
 401 (defun string-to-vector (s)
 402   "Return a resizable vector containing the elements of the string s."
 403   (declare (string s))
 404   (make-array (length s)
 405               :initial-contents s
 406               :element-type 'character
 407               :adjustable t))
 408
 409
 410 (defgeneric buffer-insert (buffer object)
 411   (:documentation "Insert OBJECT into BUFFER at the current point."))
 412
 413 (defmethod buffer-insert :after ((buf buffer) object)
 414   "Any object insertion modifies the buffer."
 415   (declare (ignore object))
 416   (setf (buffer-modified buf) t))
 417
 418 (defmethod buffer-insert ((buf buffer) (char character))
 419   "Insert a single character into buffer before point."
 420   ;; Resize the gap if needed
 421   (if (<= (buffer-gap-size buf) 1)
 422       (gap-extend buf 100))
 423   ;; Move the gap to the point
 424   (unless (= (point buf) (buffer-gap-start buf))
 425     (gap-move-to buf (buffer-point-aref buf)))
 426   (update-markers-ins buf (point buf) 1)
 427   ;; set the character
 428   (setf (aref (buffer-data buf) (buffer-gap-start buf)) char)
 429   ;; move the gap forward
 430   (incf (buffer-gap-start buf))
 431   (decf (buffer-gap-size buf))
 432   ;; expand the buffer intervals
 433   (offset-intervals buf (point buf) 1))
 434
 435 (defmethod buffer-insert ((buf buffer) (string string))
 436   ;; resize
 437   (when (<= (buffer-gap-size buf) (length string))
 438     (gap-extend buf (+ (length string) 100)))
 439   ;; move the gap to the point
 440   (unless (= (point buf) (buffer-gap-start buf))
 441     (gap-move-to buf (buffer-point-aref buf)))
 442   (update-markers-ins buf (point buf) (length string))
 443   ;; insert chars
 444   (replace (buffer-data buf) string :start1 (buffer-gap-start buf))
 445   (incf (buffer-gap-start buf) (length string))
 446   (decf (buffer-gap-size buf) (length string))
 447   ;; expand the buffer intervals
 448   (offset-intervals buf (point buf) (length string)))
 449
 450 (defmethod buffer-insert ((buf buffer) (string pstring))
 451   ;; insert string
 452   (buffer-insert buf (pstring-data string))
 453   ;; insert properties
 454   (graft-intervals-into-buffer (intervals string)
 455                                (point buf)
 456                                (pstring-length string)
 457                                buf
 458                                t))
 459
 460 (defgeneric insert-move-point (buffer object)
 461   (:documentation "Insert OBJECT into BUFFER at the current point. Move the point
 462 forward by its length."))
 463
 464 (defmethod insert-move-point ((buffer buffer) (object character))
 465   (buffer-insert buffer object)
 466   (incf (marker-position (buffer-point buffer))))
 467
 468 (defmethod insert-move-point ((buffer buffer) (object string))
 469   (buffer-insert buffer object)
 470   (incf (marker-position (buffer-point buffer)) (length object)))
 471
 472 (defmethod insert-move-point ((buffer buffer) (object pstring))
 473   (buffer-insert buffer object)
 474   (incf (marker-position (buffer-point buffer)) (pstring-length object)))
 475
 476 (defun insert (&rest objects)
 477   "Insert the arguments, either strings or characters, at point.
 478 Point and before-insertion markers move forward to end up after the
 479 inserted text. Any other markers at the point of insertion remain
 480 before the text."
 481   (dolist (o objects)
 482     (insert-move-point (current-buffer) o)))
 483
 484 (defun buffer-delete (buf p length)
 485   "Deletes chars from point to point + n. If N is negative, deletes backwards."
 486   (cond ((< length 0)
 487          (gap-move-to buf (buffer-char-to-aref buf p))
 488          (let* ((new (max 0 (+ (buffer-gap-start buf) length)))
 489                 (capped-size (- (buffer-gap-start buf) new)))
 490            (update-markers-del buf new capped-size)
 491            (adjust-intervals-for-deletion buf new capped-size)
 492            (incf (buffer-gap-size buf) capped-size)
 493            (setf (buffer-gap-start buf) new)))
 494          ((> length 0)
 495           (unless (>= p (zv buf))
 496             ;; can't delete forward if we're at the end of the buffer.
 497             (gap-move-to buf (buffer-char-to-aref buf p))
 498             ;; Make sure the gap size doesn't grow beyond the buffer size.
 499             (let ((capped-size (- (min (+ (gap-end buf) length)
 500                                        (length (buffer-data buf)))
 501                                   (gap-end buf))))
 502               (incf (buffer-gap-size buf) capped-size)
 503               (update-markers-del buf p capped-size)
 504               (adjust-intervals-for-deletion buf p capped-size)))))
 505   (setf (buffer-modified buf) t)
 506   ;; debuggning
 507   (fill-gap buf))
 508
 509 (defun buffer-erase (&optional (buf (current-buffer)))
 510   ;; update properties
 511   (adjust-intervals-for-deletion buf 0 (buffer-size buf))
 512   (update-markers-del buf 0 (buffer-size buf))
 513   ;; expand the gap to take up the whole buffer
 514   (setf (buffer-gap-start buf) 0
 515         (buffer-gap-size buf) (length (buffer-data buf))
 516         (marker-position (buffer-point buf)) 0
 517         (buffer-modified buf) t)
 518   ;; debugging
 519   (fill-gap buf))
 520
 521 (defun buffer-scan-newline (buf start limit count)
 522   "Search BUF for COUNT newlines with a limiting point at LIMIT,
 523 starting at START. Returns the point of the last newline or limit and
 524 number of newlines found. START and LIMIT are inclusive."
 525   (declare (type buffer buf)
 526            (type integer start limit count))
 527   (labels ((buffer-scan-bk (buf start limit count)
 528              "count is always >=0. start >= limit."
 529              (let* ((start-aref (buffer-char-to-aref buf start))
 530                     (limit-aref (buffer-char-to-aref buf limit))
 531                     (ceiling (if (>= start-aref (gap-end buf))
 532                                  (gap-end buf)
 533                                limit-aref))
 534                     (i 0)
 535                     ;; :END is not inclusive but START is.
 536                     (start (1+ start-aref))
 537                     p)
 538                (loop
 539                 ;; Always search at least once
 540                 (setf p (position #\Newline (buffer-data buf)
 541                                   :start ceiling :end start :from-end t))
 542                 (if p
 543                     (progn
 544                       ;; Move start. Note that start isn't set to (1+ p)
 545                       ;; because we don't want to search p again.
 546                       (setf start p)
 547                       ;; Count the newline
 548                       (incf i)
 549                       ;; Have we found enough newlines?
 550                       (when (>= i count)
 551                         (return-from buffer-scan-bk (values (buffer-aref-to-char buf p)
 552                                                             i))))
 553                   ;; Check if we've searched up to the limit
 554                   (if (= ceiling limit-aref)
 555                       (return-from buffer-scan-bk (values limit i))
 556                     ;; if not, skip past the gap
 557                     (progn
 558                       (setf ceiling limit-aref)
 559                       (setf start (buffer-gap-start buf))))))))
 560            (buffer-scan-fw (buf start limit count)
 561              "count is always >=0. start >= limit."
 562              (let* ((start-aref (buffer-char-to-aref buf start))
 563                     (limit-aref (1+ (buffer-char-to-aref buf limit)))
 564                     (ceiling (if (< start (buffer-gap-start buf))
 565                                  (buffer-gap-start buf)
 566                                limit-aref))
 567                     (i 0)
 568                     (start start-aref)
 569                     p)
 570                (loop
 571                 ;; Always search at least once
 572                 (setf p (position #\Newline (buffer-data buf) :start start :end ceiling))
 573                 (if p
 574                     (progn
 575                       ;; Move start. We don't want to search p again, thus the 1+.
 576                       (setf start (1+ p))
 577                       ;; Count the newline
 578                       (incf i)
 579                       ;; Have we found enough newlines?
 580                       (when (>= i count)
 581                         (return-from buffer-scan-fw (values (buffer-aref-to-char buf p)
 582                                                             i))))
 583                   ;; Check if we've searched up to the limit
 584                   (if (= ceiling limit-aref)
 585                       (return-from buffer-scan-fw (values limit i))
 586                     ;; if not, skip past the gap
 587                     (progn
 588                       (setf ceiling limit-aref)
 589                       (setf start (gap-end buf)))))))))
 590     ;; make sure start and limit are within the bounds
 591     (setf start (max 0 (min start (1- (buffer-size buf))))
 592           limit (max 0 (min limit (1- (buffer-size buf)))))
 593     ;; the search always fails on an empty buffer
 594     (when (= (buffer-size buf) 0)
 595       (return-from buffer-scan-newline (values limit 0)))
 596     (cond ((> count 0)
 597            (dformat +debug-vv+ "scan-fw ~a ~a ~a~%" start limit count)
 598            (buffer-scan-fw buf start limit count))
 599           ((< count 0)
 600            (dformat +debug-vv+ "scan-bk ~a ~a ~a~%" start limit count)
 601            (buffer-scan-bk buf start limit (abs count)))
 602           ;; 0 means the newline before the beginning of the current
 603           ;; line. We need to handle the case where we are on a newline.
 604           (t
 605            (dformat +debug-vv+ "scan-0 ~a ~a ~a~%" start limit count)
 606            (if (char= (buffer-char-after buf start) #\Newline)
 607                (buffer-scan-bk buf start limit 2)
 608              (buffer-scan-bk buf start limit 1))))))
 609
 610 ;; ;;; more stuff
 611
 612 ;; (defparameter +scratch-buffer+ ";; This buffer is for notes you don't want to save, and for Lisp evaluation.
 613 ;; ;; If you want to create a file, visit that file with C-x C-f,
 614 ;; ;; then enter the text in that file's own buffer.")
 615
 616 ;; (defparameter +other-buf+
 617 ;; "678901234567890 abcdefghijklmnopqrstuvwxyz
 618 ;; 1 abcdefghijklmnopqrstuvwxyz
 619 ;; 2 abcdefghijklmnopqrstuvwxyz
 620 ;; 3 abcdefghijklmnopqrstuvwxyz
 621 ;; 4 abcdefghijklmnopqrstuvwxyz
 622 ;; 5 abcdefghijklmnopqrstuvwxyz
 623 ;; 6 abcdefghijklmnopqrstuvwxyz
 624 ;; 7 abcdefghijklmnopqrstuvwxyz
 625 ;; 8 abcdefghijklmnopqrstuvwxyz")
 626
 627 ;; (defun buffer-read-from-stream (buffer stream)
 628 ;;   "Read the contents of stream until EOF, putting it in buffer-data"
 629 ;;   (loop for c = (read-char stream nil nil)
 630 ;;      until (null c)
 631 ;;      do (vector-push-extend c (buffer-data buffer))))
 632
 633 ;; (defun buffer-read-from-file (buffer file)
 634 ;;   (with-open-file (s file :direction :input)
 635 ;;     (buffer-read-from-stream buffer s)))
 636
 637 ;;; Mode-Line stuff
 638
 639 ;; FIXME: this is a parameter for debugging
 640 ;; FIXME: be more emacs-like or make it better so we don't just have
 641 ;; lambda functions that process data and return a string.
 642 (defparameter *mode-line-format* (list "--:" ;; fake it for hype
 643                                        (lambda (buffer)
 644                                          (format nil "~C~C"
 645                                               ;; FIXME: add read-only stuff
 646                                               (if (buffer-modified buffer)
 647                                                   #\* #\-)
 648                                               (if (buffer-modified buffer)
 649                                                   #\* #\-)))
 650                                        "  "
 651                                        (lambda (buffer)
 652                                          (format nil "~12,,,a" (buffer-name buffer)))
 653                                        "   "
 654                                        (lambda (buffer)
 655                                          (format nil "(~a)"
 656                                               (major-mode-name (buffer-major-mode buffer)))))
 657   "The default mode line format.")
 658
 659 (defgeneric mode-line-format-elem (buffer elem)
 660   (:documentation "Given the element found in the buffer mode-line,
 661 return a string that will be printed in the mode-line."))
 662
 663 (defmethod mode-line-format-elem ((b buffer) (elem string))
 664   "just return the string."
 665   (declare (ignore b))
 666   elem)
 667
 668 (defmethod mode-line-format-elem ((b buffer) (elem function))
 669   "Call the function. It is expected to return a string."
 670   (funcall elem b))
 671
 672 (defmethod mode-line-format-elem ((b buffer) (elem symbol))
 673   "elem is a symbol, so print its value."
 674   (princ "~a" elem))
 675
 676 (defun update-mode-line (buffer)
 677   "Given the buffer, refresh its mode-line string."
 678   (setf (buffer-mode-line-string buffer)
 679         (format nil "~{~a~}" (mapcar (lambda (elem)
 680                                 (mode-line-format-elem buffer elem))
 681                               (buffer-mode-line buffer)))))
 682
 683 (defun truncate-mode-line (buffer len)
 684 "return the buffers mode-line trunctated to len. If the mode-line is
 685 shorter than len, it will be padded with -'s."
 686   (let ((s (make-array len :element-type 'character :initial-element #\-)))
 687     (replace s (buffer-mode-line-string buffer))))
 688
 689 ;;; Buffer query/creation
 690
 691 (defgeneric get-buffer (name)
 692   (:documentation "Return the buffer named NAME. If there is no live
 693 buffer named NAME, return NIL."))
 694
 695 (defmethod get-buffer ((name string))
 696   (find name *buffer-list* :key #'buffer-name :test #'string=))
 697
 698 (defmethod get-buffer ((buffer buffer))
 699   (find buffer *buffer-list*))
 700
 701 (defgeneric get-buffer-create (name)
 702   (:documentation "Return the buffer named NAME, or create such a buffer and return it.
 703 A new buffer is created if there is no live buffer named NAME.
 704 If NAME starts with a space, the new buffer does not keep undo information.
 705 If NAME is a buffer instead of a string, then it is the value returned.
 706 The value is never nil."))
 707
 708 (defmethod get-buffer-create ((name string))
 709   (or
 710      (get-buffer name)
 711      (progn
 712        (when (zerop (length name))
 713          (error "Empty string for buffer name is not allowed"))
 714        (let ((b (make-instance 'buffer
 715                                :file nil
 716                                :point (make-marker)
 717                                :mark (make-marker)
 718                                ;; Currently a buffer has to have a gap
 719                                ;; of at least size 1.
 720                                :data (string-to-vector "_")
 721                                :gap-start 0
 722                                :gap-size 1
 723                                :mode-line *mode-line-format*
 724                                :name name
 725                                :major-mode fundamental-mode)))
 726          (set-marker (buffer-point b) 0 b)
 727          (set-marker (mark-marker b) 0 b)
 728          (push b *buffer-list*)
 729          b))))
 730
 731 (defmethod get-buffer-create ((buffer buffer))
 732   buffer)
 733
 734 ;;;
 735
 736 (defun make-default-buffers ()
 737   "Called on startup. Create the default buffers, putting them in
 738 *buffer-list*."
 739   ;; for the side effect
 740   (get-buffer-create "*messages*")
 741   (let ((scratch (get-buffer-create "*scratch*")))
 742     (buffer-insert scratch ";; This buffer is for notes you don't want to save, and for Lisp evaluation.
 743 ;; If you want to create a file, visit that file with C-x C-f,
 744 ;; then enter the text in that file's own buffer.")
 745     ;; FIXME: is this a hack?
 746     (setf (buffer-modified scratch) nil)
 747     (goto-char (point-min scratch) scratch)))
 748
 749 ;;;
 750
 751 (defun generate-new-buffer-name (name &optional ignore)
 752   "Return a string that is the name of no existing buffer based on NAME.
 753 If there is no live buffer named NAME, then return NAME.
 754 Otherwise modify name by appending `<NUMBER>', incrementing NUMBER
 755 until an unused name is found, and then return that name.
 756 Optional second argument IGNORE specifies a name that is okay to use
 757  (if it is in the sequence to be tried)
 758 even if a buffer with that name exists."
 759   (declare (type string name)
 760            (type (or string null) ignore))
 761   (or (unless (get-buffer name)
 762         name)
 763       (loop for count from 1
 764             ;; FIXME: there's gotta be a way to do this where s isn't
 765             ;; "" to start with.
 766             with s = ""
 767             do (setf s (format nil "~a<~d>" name count))
 768             when (and ignore
 769                       (string= s ignore))
 770             return ignore
 771             unless (get-buffer s)
 772             return s)))
 773
 774 (defmacro with-current-buffer (buffer &body body)
 775   "Execute the forms in BODY with BUFFER as the current buffer.
 776 The value returned is the value of the last form in BODY.
 777 See also `with-temp-buffer'."
 778   (let ((bk (gensym "BK")))
 779     `(progn
 780        (let ((,bk *current-buffer*))
 781          (set-buffer buffer)
 782          (unwind-protect
 783               (progn ,@body)
 784            (set-buffer ,bk))))))
 785
 786 (defmacro with-temp-buffer (&body body)
 787   "Create a temporary buffer, and evaluate BODY there like `progn'.
 788 See also `with-temp-file'."
 789   (let ((temp-buffer (gensym "TEMP-BUFFER")))
 790     `(let ((,temp-buffer (get-buffer-create (generate-new-buffer-name "*temp*"))))
 791        (unwind-protect
 792            (with-current-buffer ,temp-buffer
 793              ,@body)
 794          (and (get-buffer ,temp-buffer)
 795               (kill-buffer ,temp-buffer))))))
 796
 797 (defun bring-buffer-to-front (buf)
 798   "Put buf at the front of *buffer-list*. Assumes BUF is in
 799 *buffer-list*."
 800   (setf *buffer-list* (delete buf *buffer-list*))
 801   (push buf *buffer-list*))
 802
 803 (defun other-buffer (&optional (buffer (current-buffer)) visible-ok frame)
 804   "Return most recently selected buffer other than BUFFER.
 805 Buffers not visible in windows are preferred to visible buffers,
 806 unless optional second argument VISIBLE-OK is non-nil.
 807 If the optional third argument FRAME is non-nil, use that frame's
 808 buffer list instead of the selected frame's buffer list.
 809 If no other buffer exists, the buffer `*scratch*' is returned.
 810 If BUFFER is omitted or nil, some interesting buffer is returned."
 811   (declare (ignore frame))
 812   ;; TODO: honour FRAME argument
 813   (let* (vis
 814          (match (loop for b in *buffer-list*
 815                       unless (or (eq b buffer)
 816                                  (char= (char (buffer-name b) 0) #\Space))
 817                       if (and (not visible-ok)
 818                               (get-buffer-window b))
 819                       do (setf vis b)
 820                       else return b)))
 821     (or match
 822         vis
 823         (get-buffer-create "*scratch*"))))
 824
 825 (defun mark (&optional force (buffer (current-buffer)))
 826   "Return BUFFER's mark value as integer; error if mark inactive.
 827 If optional argument FORCE is non-nil, access the mark value
 828 even if the mark is not currently active, and return nil
 829 if there is no mark at all."
 830   (declare (ignore force))
 831   ;; FIXME: marks can't be inactive ATM
 832   (marker-position (mark-marker buffer)))
 833
 834 (defun validate-region (start end &optional (buffer (current-buffer)))
 835   "Return a value pair of start and end for buffer. the 1st value
 836 returned will always be <= the second. May raise an args out of range
 837 error.
 838
 839 If START or END are marks, their positions will be used."
 840   (when (typep start 'marker)
 841     (setf start (marker-position start)))
 842   (when (typep end 'marker)
 843     (setf end (marker-position end)))
 844   (when (< end start)
 845     ;; MOVITZ doesn't have psetf
 846     (let ((tmp start))
 847       (setf start end
 848             end tmp))
 849     ;; (psetf end start
 850     ;;     start end)
 851     )
 852   (when (or (< start (buffer-min buffer))
 853             (> end (buffer-max buffer)))
 854     (signal 'args-out-of-range))
 855   (values start end))
 856
 857 (defun eobp (&optional (buffer (current-buffer)))
 858   "Return T when the point is at the end of the buffer."
 859   (= (buffer-max buffer) (point)))
 860
 861 (defun bobp (&optional (buffer (current-buffer)))
 862   "Return T when the point is at the beginning of the buffer."
 863   (= (buffer-min buffer) (point)))
 864
 865 (defun set-buffer (buffer)
 866   "Make the buffer BUFFER current for editing operations.
 867 BUFFER may be a buffer or the name of an existing buffer.
 868 See also `save-excursion' when you want to make a buffer current temporarily.
 869 This function does not display the buffer, so its effect ends
 870 when the current command terminates.
 871 Use `switch-to-buffer' or `pop-to-buffer' to switch buffers permanently."
 872   (setf buffer (get-buffer buffer))
 873   (if buffer
 874       (progn
 875         (record-local-variables *current-buffer*)
 876         (set-local-variables buffer)
 877         (setf *current-buffer* buffer))
 878     (error "No buffer named ~s" buffer)))
 879
 880 (defun record-buffer (buffer)
 881   "**Move the assoc for buffer BUF to the front of buffer-alist.
 882 Since we do this each time BUF is selected visibly, the more recently
 883 selected buffers are always closer to the front of the list.  This
 884 means that other_buffer is more likely to choose a relevant buffer."
 885   (setf *buffer-list* (delete buffer *buffer-list* :test #'eq))
 886   (push buffer *buffer-list*))
 887
 888 (defun barf-if-buffer-read-only ()
 889   "Signal a `buffer-read-only' error if the current buffer is read-only."
 890   (when (buffer-read-only (current-buffer))
 891     (signal 'buffer-read-only)))
 892
 893 (defun bufferp (object)
 894   "Return t if object is an editor buffer."
 895   (typep object 'buffer))
 896
 897 (define-buffer-local :default-directory (truename "")
 898   "Name of default directory of current buffer.
 899 To interactively change the default directory, use command `cd'.")
 900
 901 (defstruct local-variable-binding
 902   value backup)
 903
 904 (defun make-local-variable (symbol)
 905   "Make variable have a separate value in the current buffer.
 906 Other buffers will continue to share a common default value.
 907  (The buffer-local value of variable starts out as the same value
 908 variable previously had.)
 909 Return variable."
 910   (setf (gethash (buffer-local-variables *current-buffer*) symbol)
 911         (make-local-variable-binding :value (symbol-value symbol)))
 912   symbol)
 913
 914 (defun record-local-variables (buffer)
 915   "Update the values BUFFER's local variables."
 916   (labels ((update (k v)
 917              (if (boundp k)
 918                  (setf (local-variable-binding-value v) (symbol-value k)
 919                        (symbol-value k) (local-variable-binding-backup v))
 920                  (remhash k (buffer-local-variables buffer)))))
 921     (maphash #'update (buffer-local-variables buffer))))
 922
 923 (defun set-local-variables (buffer)
 924   "Set all variables to the buffer local value."
 925   (labels ((set-it (k v)
 926              (if (boundp k)
 927                  (setf (local-variable-binding-backup v) (symbol-value k)
 928                        (symbol-value k) (local-variable-binding-value v))
 929                  (remhash k (buffer-local-variables buffer)))))
 930     (maphash #'set-it (buffer-local-variables buffer))))
 931
 932 (provide :lice-0.1/buffer)