insdel.lisp

   1 ;;; buffer inserting, deleting, gap management, etc
   2
   3 (in-package "LICE")
   4
   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)))
  11
  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)))
  21
  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)
  31       (replace data data
  32                :start1 (gap-end buf)
  33                :start2 old-end))
  34     ;; for debugging, mark the gap
  35     (fill-gap buf)))
  36
  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)
  40 ;;         (type integer p))
  41 ;;   (let ((aref (buffer-char-to-aref buf p)))
  42 ;;       (when (< aref (length (buffer-data buf)))
  43 ;;      (aref (buffer-data buf) aref))))
  44
  45 (defgeneric buffer-insert (buffer object)
  46   (:documentation "Insert OBJECT into BUFFER at the current point."))
  47
  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))
  52
  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)
  57       (gap-extend buf 100))
  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)
  62   ;; undo
  63   (record-insert (pt buf) 1 buf)
  64   ;; set the character
  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))
  71
  72 (defmethod buffer-insert ((buf buffer) (string string))
  73   ;; resize
  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))
  80   ;; undo
  81   (record-insert (pt buf) (length string) buf)
  82   ;; insert chars
  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)))
  88
  89 (defmethod buffer-insert ((buf buffer) (string pstring))
  90   ;; insert string
  91   (buffer-insert buf (pstring-data string))
  92   ;; insert properties
  93   (graft-intervals-into-buffer (intervals string)
  94                                (pt buf)
  95                                (pstring-length string)
  96                                buf
  97                                t))
  98
  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."))
 102
 103 (defmethod insert-move-point ((buffer buffer) (object character))
 104   (buffer-insert buffer object)
 105   (incf (marker-position (buffer-point buffer))))
 106
 107 (defmethod insert-move-point ((buffer buffer) (object string))
 108   (buffer-insert buffer object)
 109   (incf (marker-position (buffer-point buffer)) (length object)))
 110
 111 (defmethod insert-move-point ((buffer buffer) (object pstring))
 112   (buffer-insert buffer object)
 113   (incf (marker-position (buffer-point buffer)) (pstring-length object)))
 114
 115 (defun buffer-delete (buf p length)
 116   "Deletes chars from point to point + n. If N is negative, deletes backwards."
 117   (cond ((< length 0)
 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)))
 126          ((> length 0)
 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)))
 133                                   (gap-end 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)
 139   ;; debuggning
 140   (fill-gap buf))
 141
 142 (defun buffer-erase (&optional (buf (current-buffer)))
 143   ;; update properties
 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)
 152   ;; debugging
 153   (fill-gap buf))
 154
 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))