home *** CD-ROM | disk | FTP | other *** search
- ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
-
-
- ;;;----------------------------------------------------------------------------------+
- ;;; |
- ;;; TEXAS INSTRUMENTS INCORPORATED |
- ;;; P.O. BOX 149149 |
- ;;; AUSTIN, TEXAS 78714-9149 |
- ;;; |
- ;;; Copyright (C) 1990, 1990 Texas Instruments Incorporated. |
- ;;; |
- ;;; Permission is granted to any individual or institution to use, copy, modify, and |
- ;;; distribute this software, provided that this complete copyright and permission |
- ;;; notice is maintained, intact, in all copies and supporting documentation. |
- ;;; |
- ;;; Texas Instruments Incorporated provides this software "as is" without express or |
- ;;; implied warranty. |
- ;;; |
- ;;;----------------------------------------------------------------------------------+
-
- (in-package "CLIO-OPEN")
-
- (export '(
- buffer
- buffer-insert
- buffer-delete
- buffer-subseq
- buffer-length
- buffer-number-lines
-
- mark
- move-mark
- )
- 'clio-open)
-
-
- ;;; Define base character type for either CLtL or ANSI Common Lisp variants.
- (deftype buffer-character ()
- #+(or explorer ansi-common-lisp) 'base-character
- #-(or explorer ansi-common-lisp) 'string-char)
-
- ;;; PCL can't specialize methods on structure classes. Use defstruct*
- ;;; to define such structures.
- (defmacro defstruct* (name &rest slots)
- #-pcl
- `(defstruct ,name ,@slots)
-
- #+pcl
- (flet ((translate-slot (slot &optional initform &key (type t))
- `(,slot
- :initform ,initform
- :type ,type
- :initarg ,(intern (string slot) (find-package :keyword))
- :accessor ,(intern (format nil "~a-~a" name slot)))))
- (let ((pred (intern (format nil "~a-P" name))))
- `(progn
- (defclass ,name ()
- ,(mapcar #'(lambda (x) (apply #'translate-slot x)) slots)
- (:metaclass structure-class))
- (defmethod ,pred ((z t)) nil)
- (defmethod ,pred ((z ,name)) t)
- (defun ,(intern (format nil "MAKE-~a" name)) (&rest args)
- (apply #'make-instance ',name args))))))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; Vector Functions |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defconstant *vector-adjust-factor* 1.20
- "Factor used to increase the size of a vector when calling adjust-array.")
-
- (defun vector-insert (vector start &optional from (from-start 0) (count 1))
- "Insert COUNT new elements into VECTOR beginning at the START index.
- New elements, if any, are taken from FROM vector, beginning at FROM-START.
- The VECTOR index of the end of the inserted elements is returned. The
- second return value is the (possibly adjusted) vector."
- (declare (type vector vector)
- (type (or null vector) from)
- (type (integer 0 *) start from-start count))
- (declare (values end vector))
- (let* ((start (min (max start 0) (fill-pointer vector)))
- (new-length (+ (fill-pointer vector) count))
- (end (+ start count)))
-
- ;; Extend vector, if necessary
- (when (> new-length (array-dimension vector 0))
- (setf vector (adjust-array vector (ceiling (* *vector-adjust-factor* new-length))
- :fill-pointer (fill-pointer vector)))) ; Keep fill-pointer.
- (setf (fill-pointer vector) new-length)
-
- ;; Make room for new elements
- (replace vector vector :start1 end :end1 new-length :start2 start)
-
- ;; Insert new elements
- (when from
- (replace vector from :start1 start :start2 from-start :end2 (+ from-start count)))
-
- (values end vector)))
-
- (defun vector-delete (vector &optional (start 0) (end nil))
- "Deletes the substring from START to END from the VECTOR."
- (let ((start (min (max start 0) (fill-pointer vector))))
- (if end
- ;; Delete from middle
- (let* ((end (min (max end start) (fill-pointer vector))))
- (replace vector vector :start1 start :start2 end)
- (decf (fill-pointer vector) (- end start)))
-
- ;; Delete from end
- (setf (fill-pointer vector) start))))
-
-
- (defun vector-append (vector from &optional (from-start 0) from-end)
- (let* ((old-length (fill-pointer vector))
- (new-length (+ old-length (- (or from-end (length from)) from-start))))
- (when (> new-length (array-dimension vector 0))
- (adjust-array vector new-length :fill-pointer old-length)) ; Keep fill-pointer.
- (setf (fill-pointer vector) new-length)
- (replace vector from :start1 old-length :start2 from-start :end2 from-end)))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-line |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
-
- (defconstant *minimum-buffer-line-length* 10
- "Initial string dimension for a new buffer-line.")
-
- (defstruct* buffer-line
- (chars (make-array *minimum-buffer-line-length*
- :adjustable t
- :fill-pointer 0
- :element-type 'buffer-character)
- :type (array buffer-character)))
-
- (defmethod print-object ((buffer-line buffer-line) stream)
- (format stream "#<BUFFER-LINE ~a>" (substitute (code-char 0) #\newline (buffer-line-chars buffer-line))))
-
- (defgeneric buffer-line-insert (buffer-line chars position &key start end)
- (:documentation
- "Inserts the substring of CHARS given by START/END into the BUFFER-LINE at the given POSITION.
- Returns the position at the end of the inserted CHARS."))
-
- (defmethod buffer-line-insert ((buffer-line buffer-line) chars (position null) &key (start 0) end)
- (buffer-line-insert
- buffer-line chars (length (buffer-line-chars buffer-line))
- :start start
- :end end))
-
- (defmethod buffer-line-insert ((buffer-line buffer-line) (chars string) (position integer) &key (start 0) end)
- (multiple-value-bind (position chars)
- (vector-insert
- (buffer-line-chars buffer-line) position chars
- start
- (- (or end (length chars)) start))
- (setf (buffer-line-chars buffer-line) chars)
- position))
-
- (defmethod buffer-line-insert ((buffer-line buffer-line) (char character) (position integer) &key (start 0) end)
- (declare (ignore start end))
- (let ((chars (buffer-line-chars buffer-line)))
- (multiple-value-bind (new-position chars) (vector-insert chars position)
- (setf (elt chars position) char)
-
- (setf (buffer-line-chars buffer-line) chars)
- new-position)))
-
- (defmethod buffer-line-insert ((buffer-line buffer-line) (chars buffer-line) position &key (start 0) end)
- (buffer-line-insert buffer-line (buffer-line-chars chars) position :start start :end end))
-
- (defun buffer-line-delete (buffer-line &optional (start 0) (end nil))
- "Deletes the substring from START to END from the BUFFER-LINE."
- (vector-delete (buffer-line-chars buffer-line) start end))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
-
- (defconstant *minimum-buffer-length* 2
- "Initial dimension of lines array for a new buffer.")
-
- (defstruct* buffer
- (lines (make-array *minimum-buffer-length*
- :adjustable t
- :fill-pointer 0
- :element-type 'buffer-line)
- :type array))
-
- (defmethod print-object ((buffer buffer) stream)
- (format stream "#<BUFFER :LENGTH ~d>" (fill-pointer (buffer-lines buffer))))
-
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; mark |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
-
- (defstruct* mark
- (buffer nil)
- (line-index 0 :type (integer 0 *))
- (index 0 :type (integer 0 *)))
-
- ;; A composite type including all forms of positioning within text
- (deftype text-mark () '(or null ; end-of-buffer
- integer ; string array index
- mark)) ; multiline-text mark
-
- (defun mark-line (mark)
- "Return the BUFFER-LINE indicated by the MARK."
- (elt (buffer-lines (mark-buffer mark)) (mark-line-index mark)))
-
- (defgeneric move-mark (mark line &optional index)
- (:documentation "Updates MARK to point to the given LINE/INDEX.
- The new MARK is returned."))
-
- (defmethod move-mark ((mark mark) (line mark) &optional index)
- (setf (mark-buffer mark) (or (mark-buffer line) (mark-buffer mark))
- (mark-line-index mark) (mark-line-index line)
- (mark-index mark) (or index (mark-index line)))
- mark)
-
- (defmethod move-mark ((mark mark) (position integer) &optional (index nil index-p))
- (if index-p
- ;; Then POSITION is a line index and INDEX is a char index.
- (setf (mark-line-index mark) position
- (mark-index mark) index)
-
- ;; Else POSITION is a buffer index.
- (buffer-position-mark (mark-buffer mark) position mark))
- mark)
-
- (defmethod move-mark (mark new-mark &optional index)
- ;; This method allows move-mark to be used generically for all text-mark's
- (declare (ignore mark))
- (assert (not index) nil
- "Text mark is not a mark object; only a single new text-mark value may be specified.")
- new-mark)
-
- (defmethod print-object ((mark mark) stream)
- (format stream "#<MARK :LINE ~A :INDEX ~D>"
- (if (and (mark-buffer mark)
- (< (mark-line-index mark) (buffer-number-lines (mark-buffer mark))))
- (mark-line mark)
- (mark-line-index mark))
- (mark-index mark)))
-
- (defgeneric mark-equal (mark1 mark2)
- (:documentation "Returns true if the marks point to the same buffer position."))
-
- (defmethod mark-equal ((mark1 mark) (mark2 mark))
- (and (eq (mark-buffer mark1) (mark-buffer mark2))
- (= (mark-line-index mark1) (mark-line-index mark2))
- (= (mark-index mark1) (mark-index mark2))))
-
- (defmethod mark-equal (mark1 mark2)
- (eql mark1 mark2))
-
- (defvar .temp-mark. (make-mark))
-
- (defmethod mark-equal ((mark1 mark) mark2)
- (mark-equal mark1 (buffer-position-mark (mark-buffer mark1) mark2 .temp-mark.)))
-
- (defmethod mark-equal (mark1 (mark2 mark))
- (mark-equal (buffer-position-mark (mark-buffer mark2) mark1 .temp-mark.) mark2))
-
- (defgeneric mark-range (buffer mark1 mark2)
- (:documentation "Compares the marks and returns three values: the smaller mark, the larger mark,
- and the result of MARK-EQUAL."))
-
- (defmethod mark-range (buffer (mark1 mark) (mark2 mark))
- (declare (ignore buffer))
- (assert (eq (mark-buffer mark1) (mark-buffer mark2)) nil
- "~s and ~s point to different buffers.")
- (cond
- ((< (mark-line-index mark1) (mark-line-index mark2))
- (values mark1 mark2 nil))
-
- ((< (mark-line-index mark2) (mark-line-index mark1))
- (values mark2 mark1 nil))
-
- ((< (mark-index mark1) (mark-index mark2))
- (values mark1 mark2 nil))
-
- ((< (mark-index mark2) (mark-index mark1))
- (values mark2 mark1 nil))
-
- (t
- (values mark1 mark2 t))))
-
- (defmethod mark-range (buffer (mark1 mark) mark2)
- (mark-range buffer mark1 (buffer-position-mark buffer mark2 .temp-mark.)))
-
- (defmethod mark-range (buffer (mark1 integer) (mark2 integer))
- (declare (ignore buffer))
- (values (min mark1 mark2) (max mark1 mark2) (= mark1 mark2)))
-
- (defmethod mark-range (buffer (mark1 integer) mark2)
- (let ((mark2 (buffer-mark-position buffer mark2)))
- (values (min mark1 mark2) (max mark1 mark2) (= mark1 mark2))))
-
- (defmethod mark-range (buffer (mark1 null) mark2)
- (mark-range buffer (buffer-length buffer) mark2))
-
- (defgeneric buffer-mark-position (buffer mark)
- (:documentation "Return a buffer index corresponding to the MARK."))
-
- (defmethod buffer-mark-position (buffer (mark mark))
- "Return a buffer index corresponding to the MARK."
- (declare (ignore buffer))
- (let ((index 0)
- (buffer (mark-buffer mark))
- (line (mark-line-index mark)))
- (assert buffer nil "Buffer not defined for ~a." mark)
- (dotimes (i line) (incf index (buffer-length (buffer-line buffer i))))
- (incf index (mark-index mark))))
-
- (defmethod buffer-mark-position (buffer (mark integer))
- (declare (ignore buffer))
- mark)
-
- (defmethod buffer-mark-position (buffer (mark null))
- (buffer-length buffer))
-
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; Utilities |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defun parse-source (source &key (start 0) end)
- "Parse the substring of SOURCE given by START/END, returning:
- 1. The index behind the first #\newline, or END (whichever is smaller)
- 2. An array of buffer-line's containing all characters
- between the first and last #\newline's.
- 3. The index behind the last #\newline."
- (declare (type string source))
- (declare (values first-end buffer-lines tail-start))
-
- (let ((first-end (or (position #\newline source :start start :end end) end)))
- (cond
- ((eql first-end end) end)
-
- (:else
- ;; Compute end of first line.
- (incf first-end)
-
- ;; Build internal buffer-line's, if any.
- (multiple-value-bind (buffer-lines tail-start)
- (do ((next-end first-end) lines) (())
- (setf start next-end
- next-end (position #\newline source :start start :end end)
- next-end (when next-end (1+ next-end)))
-
- (unless next-end
- (return (values lines start)))
-
- (unless lines
- (setf lines (make-array *minimum-buffer-length*
- :adjustable t
- :fill-pointer 0
- :element-type 'buffer-line)))
-
- (let ((buffer-line (make-buffer-line)))
- (buffer-line-insert buffer-line source 0 :start start :end next-end)
- (vector-push-extend buffer-line lines)))
- (values first-end buffer-lines tail-start))))))
-
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-insert |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defgeneric buffer-insert (buffer chars position &key start end)
- (:documentation
- "Inserts the substring of CHARS given by START/END into the BUFFER
- at the given POSITION and returns the updated POSITION."))
-
-
- ;; buffer-line methods ----------------------------------------
-
- (defmethod buffer-insert ((buffer buffer-line) chars (position mark) &key (start 0) end)
- (assert (eq buffer (mark-buffer position)) nil "~s is not a mark for ~s." position buffer)
- (move-mark position 0 (buffer-insert buffer chars (mark-index position) :start start :end end)))
-
- (defmethod buffer-insert ((buffer buffer-line) chars (position null) &key (start 0) end)
- (buffer-insert buffer chars (length (buffer-line-chars buffer)) :start start :end end))
-
- (defmethod buffer-insert ((buffer buffer-line) (chars string) (position integer) &key (start 0) end)
- (assert (not (find #\newline chars :start start :end end)) ()
- "Can't insert #\NEWLINE into a one-line buffer.")
- (buffer-line-insert buffer chars position :start start :end end))
-
- (defmethod buffer-insert ((buffer buffer-line) (char character) (position integer) &key (start 0) end)
- (declare (ignore start end))
- (assert (not (eql char #\newline)) ()
- "Can't insert #\NEWLINE into a one-line buffer.")
- (buffer-line-insert buffer char position))
-
-
- ;; buffer methods ----------------------------------------------
-
- (defmethod buffer-insert ((buffer buffer) (chars string) (position mark) &key (start 0) end)
- (assert (eq buffer (mark-buffer position)) nil "~s is not a mark for ~s." position buffer)
-
- (when (plusp (length chars))
- (multiple-value-bind (head lines tail) (parse-source chars :start start :end end)
- (let*
- ((line (mark-line-index position))
- (insert-line (buffer-line buffer line))
-
- ;; Insert head chars at mark position
- (end-head (buffer-line-insert
- insert-line chars (mark-index position)
- :start start :end head))
-
- ;; Initialize final line/index.
- (newline-p (not (eql head end)))
- (index (if
- ;; Does insert end on another line?
- (cond
- (lines
- ;; Insert following lines into buffer line array.
- (multiple-value-bind (position vector)
- (vector-insert (buffer-lines buffer) (1+ line) lines 0 (length lines))
- (setf (buffer-lines buffer) vector)
- (setf line position)))
-
- (newline-p
- (incf line)))
-
- ;; Yes, restart index at beginning of line.
- 0
-
- ;; No, final index is end of head chars.
- end-head)))
-
- ;; Handle source chars after inserted newline.
- (when newline-p
- (let* ((buffer-lines (buffer-lines buffer))
- (insert-line-chars (buffer-line-chars insert-line))
- (insert-line-length (length insert-line-chars))
- (prev-tail-p (< end-head insert-line-length)))
-
- ;; Add a new line when...
- (when
- (or
- ;; ... tail of insert line ends in #\newline, or...
- (and prev-tail-p
- (eql #\newline (elt insert-line-chars (1- insert-line-length))))
-
- ;; ... there's something to add at the end of the buffer.
- (and (>= line (length buffer-lines)) (or tail prev-tail-p)))
-
- (multiple-value-bind (position buffer-lines) (vector-insert buffer-lines line)
- (declare (ignore position))
- (setf (buffer-lines buffer) buffer-lines)
- (setf (elt buffer-lines line) (make-buffer-line))))
-
- (let ((next-line (elt buffer-lines line)))
- ;; Insert source tail chars at beginning of next line.
- (when tail
- (setf index (buffer-line-insert next-line chars index :start tail :end end)))
-
- ;; Move previous tail of insert line, if necesssary.
- (when prev-tail-p
- (buffer-line-insert next-line insert-line index :start end-head)
- (buffer-line-delete insert-line end-head)))))
-
- ;; Return position at end of inserted chars
- (move-mark position line index))))
-
- position)
-
- (defmethod buffer-insert ((buffer buffer) (char character) (position mark) &key (start 0) end)
- (declare (ignore start end))
- (assert (eq buffer (mark-buffer position)) nil "~s is not a mark for ~s." position buffer)
-
- (let*
- ((line (mark-line-index position))
- (insert-line (buffer-line buffer line))
- (end (buffer-line-insert insert-line char (mark-index position)))
- (index (if
- ;; Does insert end on another line?
- (when (eql char #\newline) (incf line))
-
- ;; Yes, restart index at beginning of line.
- 0
-
- ;; No
- end))
- (insert-line-length (length (buffer-line-chars insert-line))))
-
- ;; ;; Is there something behind an inserted newline?
- (when (and (eql char #\newline) (< end insert-line-length))
-
- (let ((buffer-lines (buffer-lines buffer)))
- ;; Add a new line when...
- (when
- (or
- ;; ... tail of insert line ends in #\newline, or...
- (eql #\newline (elt (buffer-line-chars insert-line) (1- insert-line-length)))
-
- ;; ... we're at the end of the buffer.
- (>= line (length buffer-lines)))
-
- (multiple-value-bind (position buffer-lines) (vector-insert buffer-lines line)
- (declare (ignore position))
- (setf (buffer-lines buffer) buffer-lines)
- (setf (elt buffer-lines line) (make-buffer-line))))
-
- ;; Move previous tail of insert line
- (buffer-line-insert (elt buffer-lines line) insert-line index :start end)
- (buffer-line-delete insert-line end)))
-
- ;; Return position at end of inserted chars
- (move-mark position line index)))
-
- (defmethod buffer-insert ((buffer buffer) chars (position null) &key (start 0) end)
- (buffer-insert buffer chars (buffer-position-mark buffer position .temp-mark.) :start start :end end)
- nil)
-
- (defmethod buffer-insert ((buffer buffer) chars (position integer) &key (start 0) end)
- (buffer-insert buffer chars (buffer-position-mark buffer position .temp-mark.) :start start :end end)
- (+ position (if (characterp chars) 1 (length chars))))
-
-
- (defun buffer-position-mark (buffer position &optional mark)
- "Return a MARK pointing at the given POSITION in the BUFFER. If a MARK
- is given, then it is updated and returned; otherwise a new mark is returned."
- (declare (type buffer buffer)
- (type (or null (integer 0 *)) position))
- (declare (values mark))
- (check-type position (or null (integer 0 *)))
- (check-type buffer buffer)
-
- (let ((mark (or mark (make-mark))))
- (setf (mark-buffer mark) buffer)
-
- (multiple-value-bind (line-index index)
- (when position
- ;; Search for line/index corresponding to position.
- (do* ((lines (buffer-lines buffer))
- (nlines (length lines))
- (line 0 (1+ line)))
-
- ;; Return nil if position is past end of buffer.
- ((>= line nlines))
-
- (let* ((chars (buffer-line-chars (elt lines line)))
- (nchars (length chars)))
- (when
- (or
- ;; Position within current line?
- (< position nchars)
-
- ;; Position at end of line not ending in #\newline?
- (and (= position nchars)
- (or (zerop nchars)
- (not (eql #\newline (elt chars (1- nchars)))))))
-
- ;; Return valid line/index.
- (return (values line position)))
-
- (decf position nchars))))
-
- ;; Valid line/index found?
- (unless line-index
- (multiple-value-setq (line-index index)
-
- ;; No, return line/index for end of buffer.
- (let* ((lines (buffer-lines buffer))
- (max-line (1- (length lines)))
- (line (unless (minusp max-line) (buffer-line-chars (elt lines max-line))))
- (max-char (when line (length line))))
- (cond
- ((or
- ;; No lines?
- (minusp max-line)
-
- ;; Last line ends in #\newline?
- (when (plusp max-char)
- (eql #\newline (elt line (1- max-char)))))
-
- ;; Add empty line to empty buffer.
- (vector-push-extend (make-buffer-line) lines)
-
- ;; End of buffer is begining of new line.
- (values (1+ max-line) 0))
-
- (:else
- (values max-line max-char))))))
- (move-mark mark line-index index))))
-
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-delete |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defgeneric buffer-delete (buffer start end)
- (:documentation
- "Deletes the chars from START to END from the BUFFER."))
-
-
- ;; buffer-line methods ----------------------------------------
-
- (defmethod buffer-delete ((buffer buffer-line) (start mark) end)
- (buffer-delete buffer (mark-index start) end))
-
- (defmethod buffer-delete ((buffer buffer-line) start (end mark))
- (buffer-delete buffer start (mark-index end)))
-
- (defmethod buffer-delete ((buffer buffer-line) (start mark) (end mark))
- (buffer-delete buffer (mark-index start) (mark-index end)))
-
- (defmethod buffer-delete ((buffer buffer-line) (start integer) end)
- (vector-delete (buffer-line-chars buffer) start end))
-
-
-
- ;; buffer methods ----------------------------------------------
-
- (defmethod buffer-delete ((buffer buffer) (start integer) end)
- (buffer-delete buffer (buffer-position-mark buffer start .temp-mark.) end))
-
- (defmethod buffer-delete ((buffer buffer) start (end integer))
- (buffer-delete buffer start (buffer-position-mark buffer end .temp-mark.)))
-
- (defmethod buffer-delete ((buffer buffer) (start mark) (end null))
- (let ((line-index (mark-line-index start))
- (lines (buffer-lines buffer)))
- (buffer-line-delete (elt lines line-index) (mark-index start))
- (vector-delete lines (1+ line-index))))
-
- (defmethod buffer-delete ((buffer buffer) (start mark) (end mark))
- (assert (eq buffer (mark-buffer start)) nil
- "Start mark does not point to ~s." buffer)
- (assert (eq buffer (mark-buffer end)) nil
- "End mark does not point to ~s." buffer)
- (let*
- ((lines (buffer-lines buffer))
-
- (sli (mark-line-index start))
- (start-line (elt lines sli))
- (eli (mark-line-index end))
-
- (start-start (mark-index start))
- (start-end (when (= sli eli) (mark-index end))))
-
- ;;
- ;; Assert: start-end is non-nil iff start/end are on same line.
- ;;
- (assert (or (> eli sli) (and start-end (>= start-end start-start)))
- nil "Start mark is past end mark.")
-
- ;; Delete chars from start line.
- (buffer-line-delete start-line start-start start-end)
-
- (unless start-end
- ;; Move chars up from end line and discard end line.
- (buffer-line-insert
- start-line (buffer-line-chars (elt lines eli)) nil
- :start (mark-index end))
- (vector-delete lines eli (1+ eli))
-
- ;; Delete any lines between start and end marks.
- (vector-delete lines (1+ sli) eli))))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-length |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defgeneric buffer-length (buffer)
- (:documentation
- "Returns the number of characters in the BUFFER."))
-
- (defmethod buffer-length ((buffer buffer-line))
- (length (buffer-line-chars buffer)))
-
- (defmethod buffer-length ((buffer buffer))
- (let ((length 0)
- (lines (buffer-lines buffer)))
- (dotimes (i (length lines) length)
- (incf length (length (buffer-line-chars (elt lines i)))))))
-
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-subseq |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defgeneric buffer-subseq (buffer start end)
- (:documentation
- "Returns the BUFFER substring given by START and END."))
-
-
- ;; buffer-line methods ----------------------------------------
-
- (defmethod buffer-subseq ((buffer buffer-line) (start mark) end)
- (buffer-subseq buffer (mark-index start) end))
-
- (defmethod buffer-subseq ((buffer buffer-line) start (end mark))
- (buffer-subseq buffer start (mark-index end)))
-
- (defmethod buffer-subseq ((buffer buffer-line) (start integer) (end integer))
- (subseq (buffer-line-chars buffer) start end))
-
- (defmethod buffer-subseq ((buffer buffer-line) (start integer) (end null))
- (subseq (buffer-line-chars buffer) start end))
-
-
- ;; buffer methods ----------------------------------------------
-
- (defmethod buffer-subseq ((buffer buffer) (start integer) end)
- (buffer-subseq buffer (buffer-position-mark buffer start .temp-mark.) end))
-
- (defmethod buffer-subseq ((buffer buffer) start (end integer))
- (buffer-subseq buffer start (buffer-position-mark buffer end .temp-mark.)))
-
- (defmethod buffer-subseq ((buffer buffer) start (end null))
- (buffer-subseq buffer start (buffer-length buffer)))
-
- (defmethod buffer-subseq ((buffer buffer) (start mark) (end mark))
- (assert (eq buffer (mark-buffer start)) nil
- "Start mark does not point to ~s." buffer)
- (assert (eq buffer (mark-buffer end)) nil
- "End mark does not point to ~s." buffer)
-
- (let ((start-line (mark-line-index start))
- (start-index (mark-index start))
- (end-line (mark-line-index end))
- (end-index (mark-index end)))
-
- (assert (or (> end-line start-line)
- (and (= end-line start-line) (>= end-index start-index)))
- nil "Start mark is past end mark.")
-
- (let ((subseq (make-array *minimum-buffer-line-length*
- :adjustable t
- :fill-pointer 0
- :element-type 'buffer-character)))
- (do
- ((lines (buffer-lines buffer))
- (max (length (buffer-lines buffer)))
- (line start-line (1+ line))
- (start start-index 0))
-
- ((or (> line end-line) (>= line max)))
-
- (vector-append subseq (buffer-line-chars (elt lines line))
- start
- (when (= line end-line) end-index)))
-
- subseq)))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-number-lines |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defgeneric buffer-number-lines (buffer)
- (:documentation
- "Returns the number of lines in the BUFFER."))
-
-
- (defmethod buffer-number-lines ((buffer buffer-line))
- (if (zerop (length (buffer-line-chars buffer))) 0 1))
-
- (defmethod buffer-number-lines ((buffer buffer))
- (length (buffer-lines buffer)))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-line |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defgeneric buffer-line (buffer i)
- (:documentation
- "Returns the i'th buffer-line in the BUFFER."))
-
-
- (defmethod buffer-line ((buffer buffer-line) i)
- (when (and (plusp (length (buffer-line-chars buffer))) (zerop i))
- buffer))
-
- (defmethod buffer-line ((buffer buffer) i)
- (elt (buffer-lines buffer) i))
-
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-move-mark |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defgeneric buffer-move-mark (buffer mark &key lines chars)
- (:documentation "Move the MARK by the given number of LINES and CHARS and return the updated MARK."))
-
- (defmethod buffer-move-mark ((buffer buffer-line) (mark integer) &key (lines 0) (chars 0))
- (assert (zerop lines) nil "Cannot change line within ~a." buffer)
- (max 0 (min (+ mark chars) (length (buffer-line-chars buffer)))))
-
- (defmethod buffer-move-mark ((buffer buffer-line) (mark null) &key (lines 0) (chars 0))
- (buffer-move-mark buffer (length (buffer-line-chars buffer)) :lines lines :chars chars))
-
- (defvar .new-mark. (make-mark))
-
- (defmethod buffer-move-mark ((buffer buffer) (mark mark) &key (lines 0) (chars 0))
- (let* ((blines (buffer-lines buffer))
- (max-line (1- (length blines))))
-
- (move-mark .new-mark. mark)
-
- (unless (zerop lines)
- (setf (mark-line-index .new-mark.)
- (max 0 (min max-line (+ (mark-line-index .new-mark.) lines))))
-
- ;; Trying to move past end of line?
- (let* ((line (elt blines (mark-line-index .new-mark.)))
- (max (1- (buffer-length line))))
- (unless (or (minusp max) (eql #\newline (elt (buffer-line-chars line) max)))
- (incf max))
- (when (> (mark-index .new-mark.) max)
- (setf (mark-index .new-mark.) (max max 0)))))
-
- (unless (zerop chars)
- (setf (mark-index .new-mark.)
- (do ((position (+ (mark-index .new-mark.) chars))
- max)
- (())
- (cond
- ;; Trying to move before start of line?
- ((< position 0)
- (cond
- ;; Trying to move before first character in buffer?
- ((zerop (mark-line-index .new-mark.))
- ;; Yes, stop at first character.
- (setf position 0))
-
- ;; No, move to previous line.
- (t
- (decf (mark-line-index .new-mark.))
- (incf position (buffer-length (elt blines (mark-line-index .new-mark.)))))))
-
- ;; Trying to move past end of (not the last) line?
- ((and
- (>= position (setf max (buffer-length (elt blines (mark-line-index .new-mark.)))))
- (< (mark-line-index .new-mark.) max-line))
- ;; Yes, move to next line.
- (decf position max)
- (incf (mark-line-index .new-mark.)))
-
- ;; Trying to move past end of buffer?
- ((> position max)
- ;; Yes, stop at end of buffer.
- (setf position max))
-
- (t
- (return position))))))
- .new-mark.))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-text-extents |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defgeneric buffer-text-extents (buffer font start end &key translate)
- (:documentation "Return the width, height, ascent, and descent of the given substring of the BUFFER."))
-
- (defmethod buffer-text-extents ((buffer buffer-line) font start end &key translate)
- (multiple-value-bind (width a d l r ascent descent)
- (text-extents font (buffer-line-chars buffer)
- :start start :end end :translate translate)
- (declare (ignore a d l r))
- (values width (+ ascent descent) ascent descent)))
-
-
- ;;;----------------------------------------------------------------------------+
- ;;; |
- ;;; buffer-sol/eol |
- ;;; |
- ;;;----------------------------------------------------------------------------+
-
- (defgeneric buffer-sol (buffer position)
- (:documentation "Return the position in BUFFER at the start of the line containing POSITION."))
-
- (defmethod buffer-sol ((buffer buffer-line) position)
- (declare (ignore position))
- 0)
-
- (let ((mark (make-mark)))
- (defmethod buffer-sol ((buffer buffer) (position mark))
- (setf (mark-buffer mark) buffer)
- (move-mark mark (mark-line-index position) 0))
-
- (defmethod buffer-sol ((buffer buffer) position)
- (buffer-position-mark buffer position mark)
- (setf (mark-index mark) 0)
- mark))
-
-
- (defgeneric buffer-eol (buffer position)
- (:documentation "Return the position in BUFFER at the end of the line containing POSITION."))
-
- (defmethod buffer-eol ((buffer buffer-line) position)
- (declare (ignore position))
- (buffer-length buffer))
-
- (let ((mark (make-mark)))
- (defmethod buffer-eol ((buffer buffer) (position mark))
- (let*
- ((line (mark-line-index position))
- (bline (elt (buffer-lines buffer) line))
- (max (buffer-length bline))
- (end (if (and (plusp max) (eql #\newline (elt (buffer-line-chars bline) (1- max)))) (1- max) max)))
-
- (setf (mark-buffer mark) buffer)
- (move-mark mark line end)))
-
- (defmethod buffer-eol ((buffer buffer) position)
- (buffer-eol buffer (buffer-position-mark buffer position mark))))
-
-