| 1 | ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; **********************************************************************
|
|---|
| 4 | ;;; This code was written as part of the CMU Common Lisp project at
|
|---|
| 5 | ;;; Carnegie Mellon University, and has been placed in the public domain.
|
|---|
| 6 | ;;;
|
|---|
| 7 | #+CMU (ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; **********************************************************************
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; More Hemlock Text-Manipulation functions.
|
|---|
| 13 | ;;; Written by Skef Wholey.
|
|---|
| 14 | ;;;
|
|---|
| 15 | ;;; The code in this file implements the non-insert/delete functions in the
|
|---|
| 16 | ;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
|
|---|
| 17 | ;;;
|
|---|
| 18 |
|
|---|
| 19 | (in-package :hemlock-internals)
|
|---|
| 20 |
|
|---|
| 21 |
|
|---|
| 22 |
|
|---|
| 23 |
|
|---|
| 24 | |
|---|
| 25 |
|
|---|
| 26 | (defun region-to-string (region &optional output-string)
|
|---|
| 27 | "Returns a string containing the characters in the given Region."
|
|---|
| 28 | (close-line)
|
|---|
| 29 | (let* ((dst-length (count-characters region))
|
|---|
| 30 | (string (if (and output-string
|
|---|
| 31 | (<= dst-length (length output-string)))
|
|---|
| 32 | output-string
|
|---|
| 33 | (make-string dst-length)))
|
|---|
| 34 | (start-mark (region-start region))
|
|---|
| 35 | (end-mark (region-end region))
|
|---|
| 36 | (start-line (mark-line start-mark))
|
|---|
| 37 | (end-line (mark-line end-mark))
|
|---|
| 38 | (start-charpos (mark-charpos start-mark)))
|
|---|
| 39 | (declare (simple-string string))
|
|---|
| 40 | (if (eq start-line end-line)
|
|---|
| 41 | (%sp-byte-blt (line-chars start-line) start-charpos string 0
|
|---|
| 42 | dst-length)
|
|---|
| 43 | (let ((index ()))
|
|---|
| 44 | (let* ((line-chars (line-chars start-line))
|
|---|
| 45 | (dst-end (- (length line-chars) start-charpos)))
|
|---|
| 46 | (declare (simple-string line-chars))
|
|---|
| 47 | (%sp-byte-blt line-chars start-charpos string 0 dst-end)
|
|---|
| 48 | (setf (char string dst-end) #\newline)
|
|---|
| 49 | (setq index (1+ dst-end)))
|
|---|
| 50 | (do* ((line (line-next start-line) (line-next line))
|
|---|
| 51 | (chars (line-chars line) (line-chars line)))
|
|---|
| 52 | ((eq line end-line)
|
|---|
| 53 | (%sp-byte-blt (line-chars line) 0 string index dst-length))
|
|---|
| 54 | (declare (simple-string chars))
|
|---|
| 55 | (%sp-byte-blt (line-chars line) 0 string index
|
|---|
| 56 | (incf index (length chars)))
|
|---|
| 57 | (setf (char string index) #\newline)
|
|---|
| 58 | (setq index (1+ index)))))
|
|---|
| 59 | (values string dst-length)))
|
|---|
| 60 | |
|---|
| 61 |
|
|---|
| 62 | (defun string-to-region (string &key charprops)
|
|---|
| 63 | "Returns a region containing the characters in the given String."
|
|---|
| 64 | (let* ((string (if (simple-string-p string)
|
|---|
| 65 | string (coerce string 'simple-string)))
|
|---|
| 66 | (end (length string)))
|
|---|
| 67 | (declare (simple-string string))
|
|---|
| 68 | (do* ((index 0)
|
|---|
| 69 | (buffer (next-disembodied-buffer-counter))
|
|---|
| 70 | (previous-line)
|
|---|
| 71 | (line (make-line :%buffer buffer))
|
|---|
| 72 | (first-line line))
|
|---|
| 73 | (())
|
|---|
| 74 | (set-line-charprops line charprops)
|
|---|
| 75 | (let ((right-index (%sp-find-character string index end #\newline)))
|
|---|
| 76 | (cond (right-index
|
|---|
| 77 | (let* ((length (- right-index index))
|
|---|
| 78 | (chars (make-string length)))
|
|---|
| 79 | (%sp-byte-blt string index chars 0 length)
|
|---|
| 80 | (setf (line-chars line) chars))
|
|---|
| 81 | (setq index (1+ right-index))
|
|---|
| 82 | (setq previous-line line)
|
|---|
| 83 | (setq line (make-line :%buffer buffer))
|
|---|
| 84 | (setf (line-next previous-line) line)
|
|---|
| 85 | (setf (line-previous line) previous-line))
|
|---|
| 86 | (t
|
|---|
| 87 | (let* ((length (- end index))
|
|---|
| 88 | (chars (make-string length)))
|
|---|
| 89 | (%sp-byte-blt string index chars 0 length)
|
|---|
| 90 | (setf (line-chars line) chars))
|
|---|
| 91 | (return (renumber-region
|
|---|
| 92 | (internal-make-region
|
|---|
| 93 | (mark first-line 0 :right-inserting)
|
|---|
| 94 | (mark line (length (line-chars line))
|
|---|
| 95 | :left-inserting))))))))))
|
|---|
| 96 |
|
|---|
| 97 | (defun line-to-region (line)
|
|---|
| 98 | "Returns a region containing the specified line."
|
|---|
| 99 | (internal-make-region (mark line 0 :right-inserting)
|
|---|
| 100 | (mark line (line-length* line) :left-inserting)))
|
|---|
| 101 | |
|---|
| 102 |
|
|---|
| 103 | (defun previous-character (mark)
|
|---|
| 104 | "Returns the character immediately before the given Mark."
|
|---|
| 105 | (let ((line (mark-line mark))
|
|---|
| 106 | (charpos (mark-charpos mark)))
|
|---|
| 107 | (if (= charpos 0)
|
|---|
| 108 | (if (line-previous line)
|
|---|
| 109 | #\newline
|
|---|
| 110 | nil)
|
|---|
| 111 | (if (current-open-line-p line)
|
|---|
| 112 | (char (the simple-string (current-open-chars))
|
|---|
| 113 | (if (<= charpos (current-left-open-pos))
|
|---|
| 114 | (1- charpos)
|
|---|
| 115 | (1- (+ (current-right-open-pos) (- charpos (current-left-open-pos))))))
|
|---|
| 116 | (schar (line-chars line) (1- charpos))))))
|
|---|
| 117 |
|
|---|
| 118 | (defun next-character (mark)
|
|---|
| 119 | "Returns the character immediately after the given Mark."
|
|---|
| 120 | (let ((line (mark-line mark))
|
|---|
| 121 | (charpos (mark-charpos mark)))
|
|---|
| 122 | (if (current-open-line-p line)
|
|---|
| 123 | (if (= charpos (- (current-line-cache-length) (- (current-right-open-pos) (current-left-open-pos))))
|
|---|
| 124 | (if (line-next line)
|
|---|
| 125 | #\newline
|
|---|
| 126 | nil)
|
|---|
| 127 | (schar (current-open-chars)
|
|---|
| 128 | (if (< charpos (current-left-open-pos))
|
|---|
| 129 | charpos
|
|---|
| 130 | (+ (current-right-open-pos) (- charpos (current-left-open-pos))))))
|
|---|
| 131 | (let ((chars (line-chars line)))
|
|---|
| 132 | (if (= charpos (strlen chars))
|
|---|
| 133 | (if (line-next line)
|
|---|
| 134 | #\newline
|
|---|
| 135 | nil)
|
|---|
| 136 | (schar chars charpos))))))
|
|---|
| 137 | |
|---|
| 138 |
|
|---|
| 139 | ;;; %Set-Next-Character -- Internal
|
|---|
| 140 | ;;;
|
|---|
| 141 | ;;; This is the setf form for Next-Character. Since we may change a
|
|---|
| 142 | ;;; character to or from a newline, we must be prepared to split and
|
|---|
| 143 | ;;; join lines. We cannot just delete a character and insert the new one
|
|---|
| 144 | ;;; because the marks would not be right.
|
|---|
| 145 | ;;;
|
|---|
| 146 | (defun %set-next-character (mark character)
|
|---|
| 147 | (let* ((line (mark-line mark))
|
|---|
| 148 | (charpos (mark-charpos mark))
|
|---|
| 149 | (next (line-next line))
|
|---|
| 150 | (buffer (line-%buffer line)))
|
|---|
| 151 | (check-buffer-modification buffer mark)
|
|---|
| 152 | (modifying-buffer buffer
|
|---|
| 153 | (modifying-line line mark)
|
|---|
| 154 | (cond ((= (mark-charpos mark)
|
|---|
| 155 | (- (current-line-cache-length) (- (current-right-open-pos) (current-left-open-pos))))
|
|---|
| 156 | ;; The mark is at the end of the line.
|
|---|
| 157 | (unless next
|
|---|
| 158 | (error "~S has no next character, so it cannot be set." mark))
|
|---|
| 159 | (unless (char= character #\newline)
|
|---|
| 160 | ;; If the character is no longer a newline then mash two
|
|---|
| 161 | ;; lines together.
|
|---|
| 162 | (let ((chars (line-chars next)))
|
|---|
| 163 | (declare (simple-string chars))
|
|---|
| 164 | (setf (current-right-open-pos) (- (current-line-cache-length) (length chars)))
|
|---|
| 165 | (when (<= (current-right-open-pos) (current-left-open-pos))
|
|---|
| 166 | (grow-open-chars (* (+ (length chars) (current-left-open-pos) 1) 2)))
|
|---|
| 167 | (%sp-byte-blt chars 0 (current-open-chars) (current-right-open-pos)
|
|---|
| 168 | (current-line-cache-length))
|
|---|
| 169 | (setf (schar (current-open-chars) (current-left-open-pos)) character)
|
|---|
| 170 | (incf (current-left-open-pos)))
|
|---|
| 171 |
|
|---|
| 172 | ;; merge charprops
|
|---|
| 173 | (join-line-charprops line (line-next line))
|
|---|
| 174 |
|
|---|
| 175 | (move-some-marks (charpos next line)
|
|---|
| 176 | (+ charpos (current-left-open-pos)))
|
|---|
| 177 | (setq next (line-next next))
|
|---|
| 178 | (setf (line-next line) next)
|
|---|
| 179 | (when next (setf (line-previous next) line))))
|
|---|
| 180 | ((char= character #\newline)
|
|---|
| 181 | ;; The char is being changed to a newline, so we must split lines.
|
|---|
| 182 | (incf (current-right-open-pos))
|
|---|
| 183 | (let* ((len (- (current-line-cache-length) (current-right-open-pos)))
|
|---|
| 184 | (chars (make-string len))
|
|---|
| 185 | (new (make-line :chars chars :previous line
|
|---|
| 186 | :next next :%buffer buffer)))
|
|---|
| 187 | (%sp-byte-blt (current-open-chars) (current-right-open-pos) chars 0 len)
|
|---|
| 188 |
|
|---|
| 189 | ;; split charprops
|
|---|
| 190 | (multiple-value-bind (left right)
|
|---|
| 191 | (split-line-charprops line charpos)
|
|---|
| 192 | (setf (line-charprops-changes line) left
|
|---|
| 193 | (line-charprops-changes new) right))
|
|---|
| 194 |
|
|---|
| 195 | (maybe-move-some-marks* (charpos line new) (current-left-open-pos)
|
|---|
| 196 | (- charpos (current-left-open-pos) 1))
|
|---|
| 197 | (setf (line-next line) new)
|
|---|
| 198 | (when next (setf (line-previous next) new))
|
|---|
| 199 | (setf (current-right-open-pos) (current-line-cache-length))
|
|---|
| 200 | (number-line new)))
|
|---|
| 201 | (t
|
|---|
| 202 | (setf (char (the simple-string (current-open-chars)) (current-right-open-pos))
|
|---|
| 203 | character)
|
|---|
| 204 | (hemlock-ext:buffer-note-modification buffer mark 1)))))
|
|---|
| 205 | character)
|
|---|
| 206 |
|
|---|
| 207 | ;;; %Set-Previous-Character -- Internal
|
|---|
| 208 | ;;;
|
|---|
| 209 | ;;; The setf form for Previous-Character. We just Temporarily move the
|
|---|
| 210 | ;;; mark back one and call %Set-Next-Character.
|
|---|
| 211 | ;;;
|
|---|
| 212 | (defun %set-previous-character (mark character)
|
|---|
| 213 | (unless (mark-before mark)
|
|---|
| 214 | (error "~S has no previous character, so it cannot be set." mark))
|
|---|
| 215 | (%set-next-character mark character)
|
|---|
| 216 | (mark-after mark)
|
|---|
| 217 | character)
|
|---|
| 218 | |
|---|
| 219 |
|
|---|
| 220 | (defun count-lines (region)
|
|---|
| 221 | "Returns the number of lines in the region, first and last lines inclusive."
|
|---|
| 222 | (do ((line (mark-line (region-start region)) (line-next line))
|
|---|
| 223 | (count 1 (1+ count))
|
|---|
| 224 | (last-line (mark-line (region-end region))))
|
|---|
| 225 | ((eq line last-line) count)))
|
|---|
| 226 |
|
|---|
| 227 | (defun count-characters (region)
|
|---|
| 228 | "Returns the number of characters in the region."
|
|---|
| 229 | (let* ((start (region-start region))
|
|---|
| 230 | (end (region-end region))
|
|---|
| 231 | (first-line (mark-line start))
|
|---|
| 232 | (last-line (mark-line end)))
|
|---|
| 233 | (if (eq first-line last-line)
|
|---|
| 234 | (- (mark-charpos end) (mark-charpos start))
|
|---|
| 235 | (do ((line (line-next first-line) (line-next line))
|
|---|
| 236 | (count (1+ (- (line-length* first-line) (mark-charpos start)))))
|
|---|
| 237 | ((eq line last-line)
|
|---|
| 238 | (+ count (mark-charpos end)))
|
|---|
| 239 | (setq count (+ 1 count (line-length* line)))))))
|
|---|
| 240 |
|
|---|
| 241 | (defun line-start (mark &optional line)
|
|---|
| 242 | "Changes the Mark to point to the beginning of the Line and returns it.
|
|---|
| 243 | Line defaults to the line Mark is on."
|
|---|
| 244 | (when line
|
|---|
| 245 | (change-line mark line))
|
|---|
| 246 | (setf (mark-charpos mark) 0)
|
|---|
| 247 | mark)
|
|---|
| 248 |
|
|---|
| 249 | (defun line-end (mark &optional line)
|
|---|
| 250 | "Changes the Mark to point to the end of the line and returns it.
|
|---|
| 251 | Line defaults to the line Mark is on."
|
|---|
| 252 | (if line
|
|---|
| 253 | (change-line mark line)
|
|---|
| 254 | (setq line (mark-line mark)))
|
|---|
| 255 | (setf (mark-charpos mark) (line-length* line))
|
|---|
| 256 | mark)
|
|---|
| 257 |
|
|---|
| 258 | (defun buffer-start (mark &optional (buffer (mark-buffer mark)))
|
|---|
| 259 | "Change Mark to point to the beginning of Buffer, which defaults to
|
|---|
| 260 | the buffer Mark is currently in."
|
|---|
| 261 | (unless buffer (error "Mark ~S does not point into a buffer." mark))
|
|---|
| 262 | (move-mark mark (buffer-start-mark buffer)))
|
|---|
| 263 |
|
|---|
| 264 | (defun buffer-end (mark &optional (buffer (mark-buffer mark)))
|
|---|
| 265 | "Change Mark to point to the end of Buffer, which defaults to
|
|---|
| 266 | the buffer Mark is currently in."
|
|---|
| 267 | (unless buffer (error "Mark ~S does not point into a buffer." mark))
|
|---|
| 268 | (move-mark mark (buffer-end-mark buffer)))
|
|---|
| 269 |
|
|---|
| 270 | (defun move-mark (mark new-position)
|
|---|
| 271 | "Changes the Mark to point to the same position as New-Position."
|
|---|
| 272 | (let* ((line (mark-line new-position)))
|
|---|
| 273 | (change-line mark line))
|
|---|
| 274 | (setf (mark-charpos mark) (mark-charpos new-position))
|
|---|
| 275 | mark)
|
|---|
| 276 |
|
|---|
| 277 | |
|---|
| 278 |
|
|---|
| 279 | (defun mark-before (mark)
|
|---|
| 280 | "Changes the Mark to point one character before where it currently points.
|
|---|
| 281 | NIL is returned if there is no previous character."
|
|---|
| 282 | (let ((charpos (mark-charpos mark)))
|
|---|
| 283 | (cond ((zerop charpos)
|
|---|
| 284 | (let ((prev (line-previous (mark-line mark))))
|
|---|
| 285 | (when prev
|
|---|
| 286 | (always-change-line mark prev)
|
|---|
| 287 | (setf (mark-charpos mark) (line-length* prev))
|
|---|
| 288 | mark)))
|
|---|
| 289 | (t
|
|---|
| 290 | (setf (mark-charpos mark) (1- charpos))
|
|---|
| 291 | mark))))
|
|---|
| 292 |
|
|---|
| 293 | (defun mark-after (mark)
|
|---|
| 294 | "Changes the Mark to point one character after where it currently points.
|
|---|
| 295 | NIL is returned if there is no next character."
|
|---|
| 296 | (let ((line (mark-line mark))
|
|---|
| 297 | (charpos (mark-charpos mark)))
|
|---|
| 298 | (cond ((= charpos (line-length* line))
|
|---|
| 299 | (let ((next (line-next line)))
|
|---|
| 300 | (when next
|
|---|
| 301 | (always-change-line mark next)
|
|---|
| 302 | (setf (mark-charpos mark) 0)
|
|---|
| 303 | mark)))
|
|---|
| 304 | (t
|
|---|
| 305 | (setf (mark-charpos mark) (1+ charpos))
|
|---|
| 306 | mark))))
|
|---|
| 307 | |
|---|
| 308 |
|
|---|
| 309 | (defun character-offset (mark n)
|
|---|
| 310 | "Changes the Mark to point N characters after (or -N before if N is negative)
|
|---|
| 311 | where it currently points. If there aren't N characters before (or after)
|
|---|
| 312 | the mark, Nil is returned."
|
|---|
| 313 | (let* ((charpos (mark-charpos mark)))
|
|---|
| 314 | (if (< n 0)
|
|---|
| 315 | (let ((n (- n)))
|
|---|
| 316 | (if (< charpos n)
|
|---|
| 317 | (do ((line (line-previous (mark-line mark)) (line-previous line))
|
|---|
| 318 | (n (- n charpos 1)))
|
|---|
| 319 | ((null line) nil)
|
|---|
| 320 | (let ((length (line-length* line)))
|
|---|
| 321 | (cond ((<= n length)
|
|---|
| 322 | (always-change-line mark line)
|
|---|
| 323 | (setf (mark-charpos mark) (- length n))
|
|---|
| 324 | (return mark))
|
|---|
| 325 | (t
|
|---|
| 326 | (setq n (- n (1+ length)))))))
|
|---|
| 327 | (progn (setf (mark-charpos mark) (- charpos n))
|
|---|
| 328 | mark)))
|
|---|
| 329 | (let* ((line (mark-line mark))
|
|---|
| 330 | (length (line-length* line)))
|
|---|
| 331 | (if (> (+ charpos n) length)
|
|---|
| 332 | (do ((line (line-next line) (line-next line))
|
|---|
| 333 | (n (- n (1+ (- length charpos)))))
|
|---|
| 334 | ((null line) nil)
|
|---|
| 335 | (let ((length (line-length* line)))
|
|---|
| 336 | (cond ((<= n length)
|
|---|
| 337 | (always-change-line mark line)
|
|---|
| 338 | (setf (mark-charpos mark) n)
|
|---|
| 339 | (return mark))
|
|---|
| 340 | (t
|
|---|
| 341 | (setq n (- n (1+ length)))))))
|
|---|
| 342 | (progn (setf (mark-charpos mark) (+ charpos n))
|
|---|
| 343 | mark))))))
|
|---|
| 344 | |
|---|
| 345 |
|
|---|
| 346 | (defun line-offset (mark n &optional charpos)
|
|---|
| 347 | "Changes to Mark to point N lines after (-N before if N is negative) where
|
|---|
| 348 | it currently points. If there aren't N lines after (or before) the Mark,
|
|---|
| 349 | Nil is returned."
|
|---|
| 350 | (if (< n 0)
|
|---|
| 351 | (do ((line (mark-line mark) (line-previous line))
|
|---|
| 352 | (n n (1+ n)))
|
|---|
| 353 | ((null line) nil)
|
|---|
| 354 | (when (= n 0)
|
|---|
| 355 | (always-change-line mark line)
|
|---|
| 356 | (setf (mark-charpos mark)
|
|---|
| 357 | (if charpos
|
|---|
| 358 | (min (line-length line) charpos)
|
|---|
| 359 | (min (line-length line) (mark-charpos mark))))
|
|---|
| 360 | (return mark)))
|
|---|
| 361 | (do ((line (mark-line mark) (line-next line))
|
|---|
| 362 | (n n (1- n)))
|
|---|
| 363 | ((null line) nil)
|
|---|
| 364 | (when (= n 0)
|
|---|
| 365 | (change-line mark line)
|
|---|
| 366 | (setf (mark-charpos mark)
|
|---|
| 367 | (if charpos
|
|---|
| 368 | (min (line-length line) charpos)
|
|---|
| 369 | (min (line-length line) (mark-charpos mark))))
|
|---|
| 370 | (return mark)))))
|
|---|
| 371 |
|
|---|
| 372 | ;;; region-bounds -- Public
|
|---|
| 373 | ;;;
|
|---|
| 374 | (defun region-bounds (region)
|
|---|
| 375 | "Return as multiple-value the start and end of Region."
|
|---|
| 376 | (values (region-start region) (region-end region)))
|
|---|
| 377 |
|
|---|
| 378 | (defun set-region-bounds (region start end)
|
|---|
| 379 | "Set the start and end of Region to the marks Start and End."
|
|---|
| 380 | (let ((sl (mark-line start))
|
|---|
| 381 | (el (mark-line end)))
|
|---|
| 382 | (when (or (neq (line-%buffer sl) (line-%buffer el))
|
|---|
| 383 | (> (line-number sl) (line-number el))
|
|---|
| 384 | (and (eq sl el) (> (mark-charpos start) (mark-charpos end))))
|
|---|
| 385 | (error "Marks ~S and ~S cannot be made into a region." start end))
|
|---|
| 386 | (setf (region-start region) start (region-end region) end))
|
|---|
| 387 | region)
|
|---|
| 388 |
|
|---|
| 389 | |
|---|
| 390 |
|
|---|
| 391 | ;;;; Debugging stuff.
|
|---|
| 392 |
|
|---|
| 393 | (defun slf (string)
|
|---|
| 394 | "For a good time, figure out what this function does, and why it was written."
|
|---|
| 395 | (delete #\linefeed (the simple-string string)))
|
|---|
| 396 |
|
|---|
| 397 | (defun %print-whole-line (structure stream)
|
|---|
| 398 | (let* ((hi::*current-buffer* (or (line-buffer structure) hi::*current-buffer*)))
|
|---|
| 399 | (cond ((current-open-line-p structure)
|
|---|
| 400 | (write-string (current-open-chars) stream :end (current-left-open-pos))
|
|---|
| 401 | (write-string (current-open-chars) stream :start (current-right-open-pos)
|
|---|
| 402 | :end (current-line-cache-length)))
|
|---|
| 403 | (t
|
|---|
| 404 | (write-string (line-chars structure) stream)))))
|
|---|
| 405 |
|
|---|
| 406 | (defun %print-from-line (line startpos endpos stream)
|
|---|
| 407 | (if (not (current-open-line-p line))
|
|---|
| 408 | (write-string (line-chars line) stream :start startpos :end endpos)
|
|---|
| 409 | (let* ((open-chars (current-open-chars))
|
|---|
| 410 | (left (current-left-open-pos))
|
|---|
| 411 | (right (current-right-open-pos))
|
|---|
| 412 | (gap (- right left)))
|
|---|
| 413 | (when (< startpos left)
|
|---|
| 414 | (write-string open-chars stream :start startpos :end (min endpos left)))
|
|---|
| 415 | (when (< left endpos)
|
|---|
| 416 | (write-string open-chars stream :start (max right (+ startpos gap)) :end (+ endpos gap))))))
|
|---|
| 417 |
|
|---|
| 418 | (defun %print-before-mark (mark stream)
|
|---|
| 419 | (let* ((hi::*current-buffer* (or (mark-buffer mark) hi::*current-buffer*)))
|
|---|
| 420 | (if (mark-line mark)
|
|---|
| 421 | (let* ((line (mark-line mark))
|
|---|
| 422 | (charpos (mark-charpos mark))
|
|---|
| 423 | (startpos (max 0 (- charpos 50)))
|
|---|
| 424 | (length (line-length line)))
|
|---|
| 425 | (cond ((or (> charpos length) (< charpos 0))
|
|---|
| 426 | (write-string "{bad mark}" stream))
|
|---|
| 427 | (t
|
|---|
| 428 | (when (> startpos 0)
|
|---|
| 429 | (write-string "..." stream))
|
|---|
| 430 | (%print-from-line line startpos charpos stream))))
|
|---|
| 431 | (write-string "{deleted mark}" stream))))
|
|---|
| 432 |
|
|---|
| 433 | (defun %print-after-mark (mark stream)
|
|---|
| 434 | (let* ((hi::*current-buffer* (or (mark-buffer mark) hi::*current-buffer*)))
|
|---|
| 435 | (if (mark-line mark)
|
|---|
| 436 | (let* ((line (mark-line mark))
|
|---|
| 437 | (charpos (mark-charpos mark))
|
|---|
| 438 | (length (line-length line))
|
|---|
| 439 | (endpos (min length (+ charpos 50))))
|
|---|
| 440 | (cond ((or (> charpos length) (< charpos 0))
|
|---|
| 441 | (write-string "{bad mark}" stream))
|
|---|
| 442 | (t
|
|---|
| 443 | (%print-from-line line charpos endpos stream)
|
|---|
| 444 | (when (< endpos length)
|
|---|
| 445 | (write-string "..." stream)))))
|
|---|
| 446 | (write-string "{deleted mark}" stream))))
|
|---|
| 447 |
|
|---|
| 448 | (defun %print-hline (structure stream d)
|
|---|
| 449 | (declare (ignore d))
|
|---|
| 450 | (write-string "#<Hemlock Line \"" stream)
|
|---|
| 451 | (%print-whole-line structure stream)
|
|---|
| 452 | (write-string "\">" stream))
|
|---|
| 453 |
|
|---|
| 454 | (defun %print-hmark (structure stream d)
|
|---|
| 455 | (declare (ignore d))
|
|---|
| 456 | (let ((hi::*current-buffer* (or (mark-buffer structure) hi::*current-buffer*)))
|
|---|
| 457 | (write-string "#<Hemlock Mark \"" stream)
|
|---|
| 458 | (%print-before-mark structure stream)
|
|---|
| 459 | (write-string "^" stream)
|
|---|
| 460 | (%print-after-mark structure stream)
|
|---|
| 461 | (write-string "\">" stream)))
|
|---|
| 462 |
|
|---|
| 463 | (defvar *print-region* 10
|
|---|
| 464 | "The number of lines to print out of a region, or NIL if none.")
|
|---|
| 465 |
|
|---|
| 466 | (defun %print-hregion (region stream d)
|
|---|
| 467 | (declare (ignore d))
|
|---|
| 468 | (write-string "#<Hemlock Region \"" stream)
|
|---|
| 469 | (let* ((start (region-start region))
|
|---|
| 470 | (end (region-end region))
|
|---|
| 471 | (hi::*current-buffer* (or (mark-buffer start) hi::*current-buffer*))
|
|---|
| 472 | (first-line (mark-line start))
|
|---|
| 473 | (last-line (mark-line end)))
|
|---|
| 474 | (cond
|
|---|
| 475 | ((not (and (linep first-line) (linep last-line)
|
|---|
| 476 | (eq (line-%buffer first-line) (line-%buffer last-line))
|
|---|
| 477 | (mark<= start end)))
|
|---|
| 478 | (write-string "{bad region}" stream))
|
|---|
| 479 | (*print-region*
|
|---|
| 480 | (cond ((eq first-line last-line)
|
|---|
| 481 | (let ((cs (mark-charpos start))
|
|---|
| 482 | (ce (mark-charpos end))
|
|---|
| 483 | (len (line-length first-line)))
|
|---|
| 484 | (cond
|
|---|
| 485 | ((or (< cs 0) (> ce len))
|
|---|
| 486 | (write-string "{bad region}" stream))
|
|---|
| 487 | ((current-open-line-p first-line)
|
|---|
| 488 | (let ((gap (- (current-right-open-pos) (current-left-open-pos))))
|
|---|
| 489 | (cond
|
|---|
| 490 | ((<= ce (current-left-open-pos))
|
|---|
| 491 | (write-string (current-open-chars) stream :start cs :end ce))
|
|---|
| 492 | ((>= cs (current-left-open-pos))
|
|---|
| 493 | (write-string (current-open-chars) stream :start (+ cs gap)
|
|---|
| 494 | :end (+ ce gap)))
|
|---|
| 495 | (t
|
|---|
| 496 | (write-string (current-open-chars) stream :start cs
|
|---|
| 497 | :end (current-left-open-pos))
|
|---|
| 498 | (write-string (current-open-chars) stream :start (current-right-open-pos)
|
|---|
| 499 | :end (+ gap ce))))))
|
|---|
| 500 | (t
|
|---|
| 501 | (write-string (line-chars first-line) stream :start cs
|
|---|
| 502 | :end ce)))))
|
|---|
| 503 | (t
|
|---|
| 504 | (%print-after-mark start stream)
|
|---|
| 505 | (write-char #\/ stream)
|
|---|
| 506 | (do ((line (line-next first-line) (line-next line))
|
|---|
| 507 | (last-line (mark-line end))
|
|---|
| 508 | (cnt *print-region* (1- cnt)))
|
|---|
| 509 | ((or (eq line last-line)
|
|---|
| 510 | (when (zerop cnt) (write-string "..." stream) t))
|
|---|
| 511 | (%print-before-mark end stream))
|
|---|
| 512 | (%print-whole-line line stream)
|
|---|
| 513 | (write-char #\/ stream)))))
|
|---|
| 514 | (t
|
|---|
| 515 | (write-string "{mumble}" stream))))
|
|---|
| 516 | (write-string "\">" stream))
|
|---|
| 517 |
|
|---|
| 518 | (defun %print-hbuffer (structure stream d)
|
|---|
| 519 | (declare (ignore d))
|
|---|
| 520 | (write-string "#<Hemlock Buffer \"" stream)
|
|---|
| 521 | (write-string (buffer-name structure) stream)
|
|---|
| 522 | (write-string "\">" stream))
|
|---|
| 523 |
|
|---|
| 524 | (defun check-buffer-modification (buffer mark)
|
|---|
| 525 | (when (typep buffer 'buffer)
|
|---|
| 526 | (let* ((protected-region (buffer-protected-region buffer)))
|
|---|
| 527 | (when protected-region
|
|---|
| 528 | (let* ((prot-start (region-start protected-region))
|
|---|
| 529 | (prot-end (region-end protected-region)))
|
|---|
| 530 |
|
|---|
| 531 | (when (and (mark>= mark prot-start)
|
|---|
| 532 | (mark< mark prot-end))
|
|---|
| 533 | (editor-error "Can't modify protected buffer region.")))))))
|
|---|
