From 38c97d3460b4bc0c44ac9683192e740d506c9887 Mon Sep 17 00:00:00 2001 From: tailor Date: Mon, 7 May 2007 14:29:57 +0000 Subject: [PATCH] [lice @ massive rearrangement to get rid of compiler warnings and mimic the file structure of emacs more.] --- buffer-local.lisp | 147 ++++ buffer.lisp | 1071 ++++++-------------------- clisp-render.lisp | 2 +- cmds.lisp | 98 +++ commands.lisp | 11 + debug.lisp | 2 +- debugger.lisp | 8 +- doctor.lisp | 6 +- editfns.lisp | 124 +-- files.lisp | 19 +- frame.lisp | 467 +++++------- global.lisp | 59 +- help.lisp | 2 +- indent.lisp | 4 +- insdel.lisp | 159 ++++ intervals.lisp | 728 +++++++++--------- input.lisp => keyboard.lisp | 76 +- keymap.lisp | 104 ++- lice.asd | 89 ++- lisp-mode.lisp | 34 +- main.lisp | 26 +- major-mode.lisp | 22 +- mcl-render.lisp | 4 +- minibuffer.lisp | 40 +- movitz-render.lisp | 6 +- recursive-edit.lisp | 2 +- render.lisp | 46 ++ search.lisp | 202 ++++- simple.lisp | 583 +++++++++++--- subr.lisp | 104 +-- syntax.lisp | 1774 +++++++++++++++++++++---------------------- text-mode.lisp | 4 +- textprop.lisp | 284 +++---- tty-render.lisp | 8 +- undo.lisp | 861 ++++++--------------- window.lisp | 349 +++++++-- wm.lisp | 6 +- wrappers.lisp | 5 +- 38 files changed, 3809 insertions(+), 3727 deletions(-) create mode 100644 buffer-local.lisp create mode 100644 cmds.lisp rewrite frame.lisp (86%) create mode 100644 insdel.lisp rename input.lisp => keyboard.lisp (83%) rewrite lice.asd (85%) create mode 100644 render.lisp rewrite undo.lisp (64%) diff --git a/buffer-local.lisp b/buffer-local.lisp new file mode 100644 index 0000000..551701a --- /dev/null +++ b/buffer-local.lisp @@ -0,0 +1,147 @@ +;;; buffer local variables + +(in-package "LICE") + +(defstruct buffer-local-binding + symbol value local-p doc-string) + +(defvar *global-buffer-locals* (make-hash-table) + "The default values of buffer locals and a hash table containing all possible buffer locals") + +(defun buffer-local-exists-p (symbol) + (multiple-value-bind (v b) (gethash symbol *global-buffer-locals*) + (declare (ignore v)) + b)) + +(defun get-buffer-local-create (symbol default-value &optional doc-string) + (if (buffer-local-exists-p symbol) + (gethash symbol *global-buffer-locals*) + (setf (gethash symbol *global-buffer-locals*) + (make-buffer-local-binding :symbol symbol + :value default-value + :doc-string doc-string)))) + +(defmacro define-buffer-local (symbol default-value &optional doc-string) + "buffer locals are data hooks you can use to store values per +buffer. Use them when building minor and major modes. You +generally want to define them with this so you can create a +docstring for them. there is also `get-buffer-local-create'." + `(progn + (when (boundp ',symbol) + (warn "Symbol ~s is already bound. Existing uses of symbol will not be buffer local." ',symbol) + (makunbound ',symbol)) + (define-symbol-macro ,symbol (buffer-local ',symbol)) + (get-buffer-local-create ',symbol ,default-value ,doc-string))) + +(defun (setf buffer-local) (value symbol &optional (buffer (current-buffer))) + "Set the value of the buffer local in the current buffer." + ;; create a global buffer local entry if needed. + (let ((global-binding (get-buffer-local-create symbol value))) + ;; if the symbol becomes buffer local when set or it has a buffer + ;; value + (if (or (buffer-local-binding-local-p global-binding) + (second (multiple-value-list + (gethash symbol (buffer-locals buffer))))) + ;; set the buffer's value + (setf (gethash symbol (buffer-locals buffer)) value) + ;; set the global value + (setf (buffer-local-binding-value global-binding) value)))) + +(defun buffer-local (symbol &optional (buffer (current-buffer))) + "Return the value of the buffer local symbol. If none exists +for the current buffer then use the global one. If that doesn't +exist, throw an error." + (multiple-value-bind (v b) (gethash symbol (buffer-locals buffer)) + (if b + v + (multiple-value-bind (v b) (gethash symbol *global-buffer-locals*) + (if b + (buffer-local-binding-value v) + (error "No binding for buffer-local ~s" symbol)))))) + +(defun make-local-variable (symbol) + "Make VARIABLE have a separate value in the current buffer. +Other buffers will continue to share a common default value. +\(The buffer-local value of VARIABLE starts out as the same value +VARIABLE previously had. If VARIABLE was void, it remains void.\) +Return VARIABLE. + +If the variable is already arranged to become local when set, +this function causes a local value to exist for this buffer, +just as setting the variable would do. + +Unlike GNU/Emacs This function does not return +VARIABLE. See alse `(SETF MAKE-LOCAL-VARIABLE)'. + +See also `make-variable-buffer-local' and `define-buffer-local'. + +Do not use `make-local-variable' to make a hook variable buffer-local. +Instead, use `add-hook' and specify t for the LOCAL argument." + (setf (gethash symbol (buffer-locals (current-buffer))) (buffer-local symbol)) + ;; only setq and setf expand the symbol-macro properly, so we can't + ;; return the symbol. + nil) + +(defun (setf make-local-variable) (value symbol) + "Make the symbol local to the current buffer like +`make-local-variable' and also set its value in the buffer." + (setf (gethash symbol (buffer-locals (current-buffer))) value)) + +(defun make-variable-buffer-local (variable) + "Make VARIABLE become buffer-local whenever it is set. +At any time, the value for the current buffer is in effect, +unless the variable has never been set in this buffer, +in which case the default value is in effect. +Note that binding the variable with `let', or setting it while +a `let'-style binding made in this buffer is in effect, +does not make the variable buffer-local. Return VARIABLE. + +In most cases it is better to use `make-local-variable', +which makes a variable local in just one buffer. + +The function `default-value' gets the default value and `set-default' sets it." + (setf (buffer-local-binding-local-p (gethash variable *global-buffer-locals*)) t)) + +(defun default-value (symbol) + "Return SYMBOL's default value. +This is the value that is seen in buffers that do not have their own values +for this variable. The default value is meaningful for variables with +local bindings in certain buffers." + (buffer-local-binding-value (gethash symbol *global-buffer-locals*))) + +(defun (setf default-value) (value symbol) + "Set symbol's default value to value. symbol and value are evaluated. +The default value is seen in buffers that do not have their own values +for this variable." + (setf (buffer-local-binding-value (gethash symbol *global-buffer-locals*)) value) ) + +(depricate set-default (setf default-value)) +(defun set-default (symbol value) + "Set symbol's default value to value. symbol and value are evaluated. +The default value is seen in buffers that do not have their own values +for this variable." + (setf (default-value symbol) value)) + + +;;; Some built-in buffer local variables + +(define-buffer-local *buffer-invisibility-spec* nil + "Invisibility spec of this buffer. +The default is t, which means that text is invisible +if it has a non-nil `invisible' property. +If the value is a list, a text character is invisible if its `invisible' +property is an element in that list. +If an element is a cons cell of the form (PROP . ELLIPSIS), +then characters with property value PROP are invisible, +and they have an ellipsis as well if ELLIPSIS is non-nil.") + +(define-buffer-local *selective-display* nil + "Non-nil enables selective display. +An Integer N as value means display only lines +that start with less than n columns of space. +A value of t means that the character ^M makes itself and +all the rest of the line invisible; also, when saving the buffer +in a file, save the ^M as a newline.") + +(define-buffer-local *mark-active* nil + "Non-nil means the mark and region are currently active in this buffer.") diff --git a/buffer.lisp b/buffer.lisp index b6e7611..9cf5896 100644 --- a/buffer.lisp +++ b/buffer.lisp @@ -8,14 +8,6 @@ "All buffers managed by lice. buffers are sorted from most recently accessed to least. the CAR is the most recent buffer.") -(defvar *current-buffer* nil - "When this buffer is non-nil, it contains the current buffer. Calls -to `current-buffer' return this buffer. Otherwise, `current-buffer' -returns the current frames's current window's buffer. - -This variable should never be set using `setq' or `setf'. Bind it with -`let' for as long as it needs to be set.") - (defvar *inhibit-read-only* nil "*Non-nil means disregard read-only status of buffers or characters. If the value is t, disregard `buffer-read-only' and all `read-only' @@ -23,119 +15,16 @@ text properties. If the value is a list, disregard `buffer-read-only' and disregard a `read-only' text property if the property value is a member of the list.") -(defclass pstring () - ((data :type string :initarg :data :accessor pstring-data) - (intervals :type (or null interval) :initform nil :initarg :intervals :accessor intervals)) - (:documentation "The lice string implementation.")) - -(defmethod print-object ((obj pstring) stream) - (print-unreadable-object (obj stream :type t :identity t) - (format stream "~s" (pstring-data obj)))) - -(defun pstring-length (ps) - "Return the length of the string in PS" - (declare (type pstring ps)) - (length (pstring-data ps))) - -(defclass base-buffer () - ((file :type (or null pathname) :initarg :file :accessor buffer-file) - (name :type string :initarg :name :accessor buffer-name) - ;; mode-line - (mode-line :type list :initarg :mode-line :initform nil :accessor buffer-mode-line) - (mode-line-string :type string :initform "" :accessor buffer-mode-line-string) - (modified :type boolean :initform nil :accessor buffer-modified-p) - (read-only :type boolean :initform nil :accessor buffer-read-only) - (tick :type integer :initform 0 :accessor buffer-modified-tick :documentation - "The buffer's tick counter. It is incremented for each change -in text.") - (display-count :type integer :initform 0 :accessor buffer-display-count :documentation - "The buffer's display counter. It is incremented each time it -is displayed in a window.") - (display-time :type integer :initform 0 :accessor buffer-display-time :documentation - "The last time the buffer was switched to in a window.") - (major-mode :type major-mode :initarg :major-mode :accessor buffer-major-mode) - (local-map :initform nil :initarg :local-map :accessor buffer-local-map :documentation - "The keymap local to the buffer. This overrides major mode bindings.") - (locals-variables :type hash-table :initform (make-hash-table) :accessor buffer-local-variables) - (locals :type hash-table :initform (make-hash-table) :accessor buffer-locals)) - (:documentation "A Buffer.")) - -;; undo structures used to record types of undo information. This is -;; an alternative to the cons cells gnu emacs uses which I find -;; obscure. -(defstruct undo-entry-insertion - beg end) -(defstruct undo-entry-delete - text position) -(defstruct undo-entry-modified - time) -(defstruct undo-entry-property - prop value beg end) -(defstruct undo-entry-apply - function args) -(defstruct undo-entry-selective - delta beg end function args) -(defstruct undo-entry-marker - marker distance) - -(defclass buffer (base-buffer) - ((point :type marker :initarg :point :accessor buffer-point) - (mark :type marker :initarg :mark :accessor buffer-mark-marker) - ;; A string containing the raw buffer - (data :type (array character 1) :initarg :data :accessor buffer-data) - (intervals :type (or null interval) :initform nil :initarg :intervals :accessor intervals) - (gap-start :type integer :initarg :gap-start :accessor buffer-gap-start) - (gap-size :type integer :initarg :gap-size :accessor buffer-gap-size) - (markers :type list :initform '() :accessor buffer-markers) - (auto-save-modified :type integer :initform 0 :accessor buffer-auto-save-modified) - (modiff :type integer :initform 0 :accessor buffer-modiff) - ;;(syntax-table :initform *standard-syntax-table* :accessor buffer-syntax-table) - (undo-list :initform '() :accessor buffer-undo-list - :documentation "List of undo entries in current buffer. -Recent changes come first; older changes follow newer. - -An entry (BEG . END) represents an insertion which begins at -position BEG and ends at position END. - -An entry (TEXT . POSITION) represents the deletion of the string TEXT -from (abs POSITION). If POSITION is positive, point was at the front -of the text being deleted; if negative, point was at the end. - -An entry (t HIGH . LOW) indicates that the buffer previously had -\"unmodified\" status. HIGH and LOW are the high and low 16-bit portions -of the visited file's modification time, as of that time. If the -modification time of the most recent save is different, this entry is -obsolete. - -An entry (nil PROPERTY VALUE BEG . END) indicates that a text property -was modified between BEG and END. PROPERTY is the property name, -and VALUE is the old value. - -An entry (apply FUN-NAME . ARGS) means undo the change with -\(apply FUN-NAME ARGS). - -An entry (apply DELTA BEG END FUN-NAME . ARGS) supports selective undo -in the active region. BEG and END is the range affected by this entry -and DELTA is the number of bytes added or deleted in that range by -this change. - -An entry (MARKER . DISTANCE) indicates that the marker MARKER -was adjusted in position by the offset DISTANCE (an integer). - -An entry of the form POSITION indicates that point was at the buffer -location given by the integer. Undoing an entry of this form places -point at POSITION. - -nil marks undo boundaries. The undo command treats the changes -between two undo boundaries as a single step to be undone. - -If the value of the variable is t, undo information is not recorded. -")) - (:documentation "A text Buffer.")) - -(defmethod print-object ((obj buffer) stream) - (print-unreadable-object (obj stream :type t :identity t) - (format stream "~a" (buffer-name obj)))) +(defvar *default-major-mode* 'fundamental-mode + "*Major mode for new buffers. Defaults to `fundamental-mode'. +A value of nil means use current buffer's major mode, +provided it is not marked as \"special\". + +When a mode is used by default, `find-file' switches to it +before it reads the contents into the buffer and before +it finishes setting up the buffer. Thus, the mode and +its hooks should not expect certain variables such as +`buffer-read-only' and `buffer-file-coding-system' to be set up.") (define-condition args-out-of-range (lice-condition) () (:documentation "Raised when some arguments (usually relating to a @@ -160,264 +49,9 @@ If you set the marker not to point anywhere, the buffer will have no mark." (buffer-mark-marker buffer)) -;;; buffer locals - -(defstruct buffer-local-binding - symbol value local-p doc-string) - -(defvar *global-buffer-locals* (make-hash-table) - "The default values of buffer locals and a hash table containing all possible buffer locals") - -(defun buffer-local-exists-p (symbol) - (multiple-value-bind (v b) (gethash symbol *global-buffer-locals*) - (declare (ignore v)) - b)) - -(defun get-buffer-local-create (symbol default-value &optional doc-string) - (if (buffer-local-exists-p symbol) - (gethash symbol *global-buffer-locals*) - (setf (gethash symbol *global-buffer-locals*) - (make-buffer-local-binding :symbol symbol - :value default-value - :doc-string doc-string)))) - -(defmacro define-buffer-local (symbol default-value &optional doc-string) - "buffer locals are data hooks you can use to store values per -buffer. Use them when building minor and major modes. You -generally want to define them with this so you can create a -docstring for them. there is also `get-buffer-local-create'." - `(progn - (when (boundp ',symbol) - (warn "Symbol ~s is already bound. Existing uses of symbol will not be buffer local." ',symbol) - (makunbound ',symbol)) - (define-symbol-macro ,symbol (buffer-local ',symbol)) - (get-buffer-local-create ',symbol ,default-value ,doc-string))) - -(defun (setf buffer-local) (value symbol) - "Set the value of the buffer local in the current buffer." - ;; create a global buffer local entry if needed. - (let ((global-binding (get-buffer-local-create symbol value))) - ;; if the symbol becomes buffer local when set or it has a buffer - ;; value - (if (or (buffer-local-binding-local-p global-binding) - (second (multiple-value-list - (gethash symbol (buffer-locals *current-buffer*))))) - ;; set the buffer's value - (setf (gethash symbol (buffer-locals *current-buffer*)) value) - ;; set the global value - (setf (buffer-local-binding-value global-binding) value)))) - -(defun buffer-local (symbol) - "Return the value of the buffer local symbol. If none exists -for the current buffer then use the global one. If that doesn't -exist, throw an error." - (multiple-value-bind (v b) (gethash symbol (buffer-locals *current-buffer*)) - (if b - v - (multiple-value-bind (v b) (gethash symbol *global-buffer-locals*) - (if b - (buffer-local-binding-value v) - (error "No binding for buffer-local ~s" symbol)))))) - -(defun make-local-variable (symbol) - "Make VARIABLE have a separate value in the current buffer. -Other buffers will continue to share a common default value. -\(The buffer-local value of VARIABLE starts out as the same value -VARIABLE previously had. If VARIABLE was void, it remains void.\) -Return VARIABLE. - -If the variable is already arranged to become local when set, -this function causes a local value to exist for this buffer, -just as setting the variable would do. - -Unlike GNU/Emacs This function does not return -VARIABLE. See alse `(SETF MAKE-LOCAL-VARIABLE)'. - -See also `make-variable-buffer-local' and `define-buffer-local'. - -Do not use `make-local-variable' to make a hook variable buffer-local. -Instead, use `add-hook' and specify t for the LOCAL argument." - (setf (gethash symbol (buffer-locals *current-buffer*)) (buffer-local symbol)) - ;; only setq and setf expand the symbol-macro properly, so we can't - ;; return the symbol. - nil) - -(defun (setf make-local-variable) (value symbol) - "Make the symbol local to the current buffer like -`make-local-variable' and also set its value in the buffer." - (setf (gethash symbol (buffer-locals *current-buffer*)) value)) - -(defun make-variable-buffer-local (variable) - "Make VARIABLE become buffer-local whenever it is set. -At any time, the value for the current buffer is in effect, -unless the variable has never been set in this buffer, -in which case the default value is in effect. -Note that binding the variable with `let', or setting it while -a `let'-style binding made in this buffer is in effect, -does not make the variable buffer-local. Return VARIABLE. - -In most cases it is better to use `make-local-variable', -which makes a variable local in just one buffer. - -The function `default-value' gets the default value and `set-default' sets it." - (setf (buffer-local-binding-local-p (gethash variable *global-buffer-locals*)) t)) - -(defun default-value (symbol) - "Return SYMBOL's default value. -This is the value that is seen in buffers that do not have their own values -for this variable. The default value is meaningful for variables with -local bindings in certain buffers." - (buffer-local-binding-value (gethash symbol *global-buffer-locals*))) - -(defun (setf default-value) (value symbol) - "Set symbol's default value to value. symbol and value are evaluated. -The default value is seen in buffers that do not have their own values -for this variable." - (setf (buffer-local-binding-value (gethash symbol *global-buffer-locals*)) value) ) - -(depricate set-default (setf default-value)) -(defun set-default (symbol value) - "Set symbol's default value to value. symbol and value are evaluated. -The default value is seen in buffers that do not have their own values -for this variable." - (setf (default-value symbol) value)) - -(define-buffer-local *buffer-invisibility-spec* nil - "Invisibility spec of this buffer. -The default is t, which means that text is invisible -if it has a non-nil `invisible' property. -If the value is a list, a text character is invisible if its `invisible' -property is an element in that list. -If an element is a cons cell of the form (PROP . ELLIPSIS), -then characters with property value PROP are invisible, -and they have an ellipsis as well if ELLIPSIS is non-nil.") - -(define-buffer-local *selective-display* nil - "Non-nil enables selective display. -An Integer N as value means display only lines -that start with less than n columns of space. -A value of t means that the character ^M makes itself and -all the rest of the line invisible; also, when saving the buffer -in a file, save the ^M as a newline.") - - - -;;; buffer related conditions - -;;(define-condition end-of-buffer) - - -;;; Markers - -(deftype marker-insertion-type () '(member :before :after)) - -(defclass marker () - ((position :type integer :initform 0 :accessor marker-position) - (buffer :type (or buffer null) :initform nil :accessor marker-buffer) - (insertion-type :type marker-insertion-type :initform :after :accessor marker-insertion-type)) - (:documentation "A Marker")) - -(defmethod print-object ((obj marker) stream) - (print-unreadable-object (obj stream :type t :identity t) - (format stream "~a" (marker-position obj)))) - -(defgeneric ensure-number (thing) - (:documentation "Call this function when THING could be a number or a marker or...?")) - -(defmethod ensure-number ((thing number)) - thing) - -(defmethod ensure-number ((thing marker)) - (marker-position thing)) - -(defun copy-marker (marker &optional (type :after)) - "Return a new marker pointing at the same place as MARKER. -If argument is a number, makes a new marker pointing -at that position in the current buffer. -**The optional argument TYPE specifies the insertion type of the new marker; -**see `marker-insertion-type'." - (check-type marker (or marker integer)) - (check-type type marker-insertion-type) - (let ((new (make-marker))) - (set-marker new (ensure-number marker) - (if (typep marker 'marker) - (marker-buffer marker) - (current-buffer))) - (setf (marker-insertion-type new) type) - new)) - -(defun make-marker () - "Return a newly allocated marker which does not point anywhere." - (make-instance 'marker)) - -(defun unchain-marker (marker) - (when (marker-buffer marker) - (setf (buffer-markers (marker-buffer marker)) - (delete marker (buffer-markers (marker-buffer marker)) :key #'weak-pointer-value)))) - -(defun chain-marker (marker buffer) - (push (make-weak-pointer marker) (buffer-markers buffer))) - -(defun set-marker (marker position &optional (buffer (current-buffer))) - ;; remove the marker from its buffer, when appropriate - (when (null position) - (unchain-marker marker) - (return-from set-marker marker)) - ;; XXX handle dead buffers - - ;; normalize pos - (setf (marker-position marker) (min (max position (begv buffer)) (zv buffer))) - - ;; update buffer stuff - (unless (eq (marker-buffer marker) buffer) - (unchain-marker marker) - (setf (marker-buffer marker) buffer) - (chain-marker marker buffer)) - marker) - -(defun update-markers-del (buffer start size) - ;; FIXME: insertion-type - ;; First get rid of stale markers - (purge-markers buffer) - (dolist (wp (buffer-markers buffer)) - (let ((m (weak-pointer-value wp))) - ;; paranoia, maybe the GC freed some stuff after the marker - ;; purge. - (when m - ;; markers are before the marker-position. - (cond ((>= (marker-position m) (+ start size)) - (decf (marker-position m) size)) - ((> (marker-position m) start) - (setf (marker-position m) start))))))) - -(defun update-markers-ins (buffer start size) - ;; FIXME: insertion-type - ;; First get rid of stale markers - (purge-markers buffer) - (dolist (wp (buffer-markers buffer)) - (let ((m (weak-pointer-value wp))) - ;; markers are before the marker-position. - (when (and m (> (marker-position m) start) - (incf (marker-position m) size)))))) - -(defun purge-markers (buffer) - "Remove GC'd markers." - (setf (buffer-markers buffer) - (delete-if (lambda (m) - (multiple-value-bind (v c) (weak-pointer-value m) - (declare (ignore v)) - (not c))) - (buffer-markers buffer)))) - - -;;; - -(defun inc-buffer-tick (buffer) - "Increment the buffer's ticker." - (incf (buffer-modified-tick buffer))) - -;;; Some wrappers around replace +;;; gap basics +;; Some wrappers around replace (defun move-subseq-left (seq from end to) "Move the subseq between from and end to before TO, which is assumed to be left of FROM." @@ -437,10 +71,32 @@ end, inclusive, to before TO." (move-subseq-left seq from end to) (move-subseq-right seq from end to))) +(defun gap-end (buf) + "The end of the gap. in aref space. gap-end is the first valid +buffer character." + (declare (type buffer buf)) + (+ (buffer-gap-start buf) (buffer-gap-size buf))) + (defun fill-gap (buf) "For debugging purposes. fill the gap with _'s." (fill (buffer-data buf) #\_ :start (buffer-gap-start buf) :end (gap-end buf))) +(defun buffer-aref-to-char (buf idx) + "Translate the index into the buffer data to the index excluding the gap." + (declare (type buffer buf) + (type integer idx)) + (if (>= idx (gap-end buf)) + (- idx (buffer-gap-size buf)) + idx)) + +(defun buffer-char-to-aref (buf p) + "" + (declare (type buffer buf) + (type integer p)) + (if (>= p (buffer-gap-start buf)) + (+ p (buffer-gap-size buf)) + p)) + (defun gap-move-to (buf to) "A basic function to move the gap. TO is in aref coordinates and the gap is positioned before TO. @@ -469,70 +125,6 @@ A___BCDEF ;; (replace data data :start1 (+ to (buffer-gap-size buf)) :start2 to) ;; (setf (buffer-gap-start buf) to))) -(defun gap-end (buf) - "The end of the gap. in aref space. gap-end is the first valid -buffer character." - (declare (type buffer buf)) - (+ (buffer-gap-start buf) (buffer-gap-size buf))) - -(defmacro inc-aref (var buffer) - "increment VAR one character forward in BUFFER, avoiding the gap." - `(progn - (incf ,var) - (if (= (buffer-gap-start ,buffer) ,var) - (setf ,var (gap-end ,buffer))))) - -(defmacro inc-both (char-var aref-var buffer) - `(progn - (inc-aref ,aref-var ,buffer) - (incf ,char-var))) - -(defun aref-minus-1 (aref buffer) - (if (= (gap-end buffer) aref) - (1- (buffer-gap-start buffer)) - (1- aref))) - -(defmacro dec-aref (var buffer) - "increment VAR one character forward in BUFFER, avoiding the gap." - `(setf ,var (aref-minus-1 ,var ,buffer))) - -(defmacro dec-both (char-var aref-var buffer) - `(progn - (dec-aref ,aref-var ,buffer) - (decf ,char-var))) - -;; (defun gap-close (buf) -;; "Move the gap to the end of the buffer." -;; (let ((gap-start (buffer-gap-start buf)) -;; (gap-end (gap-end buf))) -;; (setf (buffer-gap-start buf) (- (length (buffer-data buf)) (buffer-gap-size buf))) -;; (replace (buffer-data buf) (buffer-data buf) :start1 gap-start :start2 gap-end))) - -(defun grow-buffer-data (buf size) - "Grow the buffer data array to be SIZE. SIZE must be larger than before." - ;; MOVITZ doesn't have adjust-array - ;; ;; #\_ is used for debugging to represent the gap - ;; (adjust-array (buffer-data buf) size :initial-element #\_ :fill-pointer t) - (let ((newbuf (make-array size :initial-element #\_;; :fill-pointer t - :element-type 'character))) - (replace newbuf (buffer-data buf)) - (setf (buffer-data buf) newbuf))) - -(defun gap-extend (buf size) - "Extend the gap by SIZE characters." - (let ((new-size (+ (length (buffer-data buf)) size)) - (old-end (gap-end buf)) - (old-size (buffer-size buf)) - (data (buffer-data buf))) - (setf data (grow-buffer-data buf new-size)) - (incf (buffer-gap-size buf) size) - (unless (= (buffer-gap-start buf) old-size) - (replace data data - :start1 (gap-end buf) - :start2 old-end)) - ;; for debugging, mark the gap - (fill-gap buf))) - (defun buffer-size (buf) "Return the length of the buffer not including the gap." (declare (type buffer buf)) @@ -570,22 +162,39 @@ buffer character." ;; TODO: handle buffer narrowing (buffer-char-to-aref buf (buffer-max buf))) -(defun point (&optional (buffer (current-buffer))) - "Return the point in the current buffer." - (marker-position (buffer-point buffer))) +(defmacro inc-aref (var buffer) + "increment VAR one character forward in BUFFER, avoiding the gap." + `(progn + (incf ,var) + (if (= (buffer-gap-start ,buffer) ,var) + (setf ,var (gap-end ,buffer))))) -(defun point-marker (&optional (buffer (current-buffer))) - "Return value of point, as a marker object." - (buffer-point buffer)) +(defmacro inc-both (char-var aref-var buffer) + `(progn + (inc-aref ,aref-var ,buffer) + (incf ,char-var))) -(defun point-min (&optional (buffer (current-buffer))) - "Return the minimum permissible value of point in the current buffer." - (declare (ignore buffer)) - 0) +(defun aref-minus-1 (aref buffer) + (if (= (gap-end buffer) aref) + (1- (buffer-gap-start buffer)) + (1- aref))) + +(defmacro dec-aref (var buffer) + "increment VAR one character forward in BUFFER, avoiding the gap." + `(setf ,var (aref-minus-1 ,var ,buffer))) + +(defmacro dec-both (char-var aref-var buffer) + `(progn + (dec-aref ,aref-var ,buffer) + (decf ,char-var))) -(defun point-max (&optional (buffer (current-buffer))) - "Return the maximum permissible value of point in the current buffer." - (buffer-size buffer)) +(defun pt (&optional (buffer (current-buffer))) + "Return the point in the current buffer." + (marker-position (buffer-point buffer))) + +(defun buffer-point-aref (buf) + "Return the buffer point in aref coordinates." + (buffer-char-to-aref buf (pt buf))) (defun set-point-both (buffer char-pos aref-pos) "Set point in BUFFER to CHARPOS, which corresponds to byte @@ -598,25 +207,10 @@ before an intangible character, move to an ok place." (defun set-point (char-pos &optional (buffer (current-buffer))) (set-point-both buffer char-pos nil)) -(defun goto-char (position &optional (buffer (current-buffer))) - "Set point to POSITION, a number." - (check-number-coerce-marker position) - (when (and (>= position (point-min buffer)) - (<= position (point-max buffer))) - (set-point position buffer))) - -;; (defun buffer-char-before-point (buf p) -;; "The character at the point P in buffer BUF. P is in char space." -;; (declare (type buffer buf) -;; (type integer p)) -;; (let ((aref (buffer-char-to-aref buf p))) -;; (when (< aref (length (buffer-data buf))) -;; (aref (buffer-data buf) aref)))) - (defun buffer-char-after (buf p) "The character at the point P in buffer BUF. P is in char space." (declare (type buffer buf) - (type integer p)) + (type (integer 0 *) p)) (let ((aref (buffer-char-to-aref buf p))) (when (and (>= aref 0) (< aref (length (buffer-data buf)))) @@ -625,320 +219,115 @@ before an intangible character, move to an ok place." (defun buffer-char-before (buf p) (buffer-char-after buf (1- p))) -(defun char-after (&optional (pos (point))) - "Return character in current buffer at position POS. -***POS is an integer or a marker. -***If POS is out of range, the value is nil." - (buffer-char-after (current-buffer) pos)) -(defun char-before (&optional (pos (point))) - "Return character in current buffer preceding position POS. -***POS is an integer or a marker. -***If POS is out of range, the value is nil." - (char-after (1- pos))) +(defun buffer-fetch-char (aref buf) + (aref (buffer-data buf) aref)) -(defun buffer-aref-to-char (buf idx) - "Translate the index into the buffer data to the index excluding the gap." - (declare (type buffer buf) - (type integer idx)) - (if (>= idx (gap-end buf)) - (- idx (buffer-gap-size buf)) - idx)) + +;;; Markers -(defun buffer-char-to-aref (buf p) - "" - (declare (type buffer buf) - (type integer p)) - (if (>= p (buffer-gap-start buf)) - (+ p (buffer-gap-size buf)) - p)) +(defgeneric ensure-number (thing) + (:documentation "Call this function when THING could be a number or a marker or...?")) -(defun buffer-point-aref (buf) - "Return the buffer point in aref coordinates." - (buffer-char-to-aref buf (point buf))) +(defmethod ensure-number ((thing number)) + thing) -(defun buffer-fetch-char (aref buf) - (aref (buffer-data buf) aref)) +(defmethod ensure-number ((thing marker)) + (marker-position thing)) -(defun string-to-vector (s) - "Return a resizable vector containing the elements of the string s." - (declare (string s)) - (make-array (length s) - :initial-contents s - :element-type 'character - :adjustable t)) +(defmacro check-number-coerce-marker (marker-var) + "Verify that MARKER-VAR is a number or if it's a marker then +set the var to the marker's position." + `(progn + (check-type ,marker-var (or marker (integer 0 *))) + (when (typep ,marker-var 'marker) + (setf ,marker-var (marker-position ,marker-var))))) +(defun make-marker () + "Return a newly allocated marker which does not point anywhere." + (make-instance 'marker)) -(defgeneric buffer-insert (buffer object) - (:documentation "Insert OBJECT into BUFFER at the current point.")) - -(defmethod buffer-insert :after ((buf buffer) object) - "Any object insertion modifies the buffer." - (declare (ignore object)) - (setf (buffer-modified-p buf) t)) - -(defmethod buffer-insert ((buf buffer) (char character)) - "Insert a single character into buffer before point." - ;; Resize the gap if needed - (if (<= (buffer-gap-size buf) 1) - (gap-extend buf 100)) - ;; Move the gap to the point - (unless (= (point buf) (buffer-gap-start buf)) - (gap-move-to buf (buffer-point-aref buf))) - (update-markers-ins buf (point buf) 1) - ;; undo - (record-insert (point buf) 1 buf) - ;; set the character - (setf (aref (buffer-data buf) (buffer-gap-start buf)) char) - ;; move the gap forward - (incf (buffer-gap-start buf)) - (decf (buffer-gap-size buf)) - ;; expand the buffer intervals - (offset-intervals buf (point buf) 1)) - -(defmethod buffer-insert ((buf buffer) (string string)) - ;; resize - (when (<= (buffer-gap-size buf) (length string)) - (gap-extend buf (+ (length string) 100))) - ;; move the gap to the point - (unless (= (point buf) (buffer-gap-start buf)) - (gap-move-to buf (buffer-point-aref buf))) - (update-markers-ins buf (point buf) (length string)) - ;; undo - (record-insert (point buf) (length string) buf) - ;; insert chars - (replace (buffer-data buf) string :start1 (buffer-gap-start buf)) - (incf (buffer-gap-start buf) (length string)) - (decf (buffer-gap-size buf) (length string)) - ;; expand the buffer intervals - (offset-intervals buf (point buf) (length string))) - -(defmethod buffer-insert ((buf buffer) (string pstring)) - ;; insert string - (buffer-insert buf (pstring-data string)) - ;; insert properties - (graft-intervals-into-buffer (intervals string) - (point buf) - (pstring-length string) - buf - t)) - -(defgeneric insert-move-point (buffer object) - (:documentation "Insert OBJECT into BUFFER at the current point. Move the point -forward by its length.")) - -(defmethod insert-move-point ((buffer buffer) (object character)) - (buffer-insert buffer object) - (incf (marker-position (buffer-point buffer)))) - -(defmethod insert-move-point ((buffer buffer) (object string)) - (buffer-insert buffer object) - (incf (marker-position (buffer-point buffer)) (length object))) - -(defmethod insert-move-point ((buffer buffer) (object pstring)) - (buffer-insert buffer object) - (incf (marker-position (buffer-point buffer)) (pstring-length object))) - -(defun insert (&rest objects) - "Insert the arguments, either strings or characters, at point. -Point and before-insertion markers move forward to end up after the -inserted text. Any other markers at the point of insertion remain -before the text." - (dolist (o objects) - (insert-move-point (current-buffer) o))) - -(defun buffer-delete (buf p length) - "Deletes chars from point to point + n. If N is negative, deletes backwards." - (cond ((< length 0) - (gap-move-to buf (buffer-char-to-aref buf p)) - (let* ((new (max 0 (+ (buffer-gap-start buf) length))) - (capped-size (- (buffer-gap-start buf) new))) - (update-markers-del buf new capped-size) - (record-delete new (buffer-substring new (+ new capped-size))) - (adjust-intervals-for-deletion buf new capped-size) - (incf (buffer-gap-size buf) capped-size) - (setf (buffer-gap-start buf) new))) - ((> length 0) - (unless (>= p (zv buf)) - ;; can't delete forward if we're at the end of the buffer. - (gap-move-to buf (buffer-char-to-aref buf p)) - ;; Make sure the gap size doesn't grow beyond the buffer size. - (let ((capped-size (- (min (+ (gap-end buf) length) - (length (buffer-data buf))) - (gap-end buf)))) - (record-delete p (buffer-substring p (+ p capped-size))) - (incf (buffer-gap-size buf) capped-size) - (update-markers-del buf p capped-size) - (adjust-intervals-for-deletion buf p capped-size))))) - (setf (buffer-modified-p buf) t) - ;; debuggning - (fill-gap buf)) +(defun unchain-marker (marker) + (when (marker-buffer marker) + (setf (buffer-markers (marker-buffer marker)) + (delete marker (buffer-markers (marker-buffer marker)) :key #'weak-pointer-value)))) -(defun buffer-erase (&optional (buf (current-buffer))) - ;; update properties - (record-delete (begv buf) (buffer-substring (begv buf) (zv buf) buf) buf) - (adjust-intervals-for-deletion buf 0 (buffer-size buf)) - (update-markers-del buf 0 (buffer-size buf)) - ;; expand the gap to take up the whole buffer - (setf (buffer-gap-start buf) 0 - (buffer-gap-size buf) (length (buffer-data buf)) - (marker-position (buffer-point buf)) 0 - (buffer-modified-p buf) t) - ;; debugging - (fill-gap buf)) +(defun chain-marker (marker buffer) + (push (make-weak-pointer marker) (buffer-markers buffer))) -(defun scan-buffer (buffer target start end count) -"Search for COUNT instances of the character TARGET between START and END. - -If COUNT is positive, search forwards; END must be >= START. -If COUNT is negative, search backwards for the -COUNTth instance; - END must be <= START. -If COUNT is zero, do anything you please; run rogue, for all I care. - -If END is NIL, use BEGV or ZV instead, as appropriate for the -direction indicated by COUNT. - -If we find COUNT instances, return the -position past the COUNTth match and 0. Note that for reverse motion -this is not the same as the usual convention for Emacs motion commands. - -If we don't find COUNT instances before reaching END, return END -and the number of TARGETs left unfound." - (let ((shortage (abs count)) - last) - (if (> count 0) - (setf end (or end (zv buffer))) - (setf end (or end (begv buffer)))) - (setf start (buffer-char-to-aref buffer start) - end (buffer-char-to-aref buffer end)) - (loop while (and (> count 0) - (/= start end)) do - (setf start - (if (< start (buffer-gap-start buffer)) - (or (position target (buffer-data buffer) :start start :end (min end (buffer-gap-start buffer))) - (and (> end (gap-end buffer)) - (position target (buffer-data buffer) :start (gap-end buffer) :end end))) - (position target (buffer-data buffer) :start start :end end))) - (if start - (setf start (1+ start) - last start - count (1- count) - shortage (1- shortage)) - (setf start end))) - (loop while (and (< count 0) - (/= start end)) do - (setf start - (if (> start (buffer-gap-start buffer)) - (or (position target (buffer-data buffer) :start (max end (gap-end buffer)) :end start :from-end t) - (and (< end (buffer-gap-start buffer)) - (position target (buffer-data buffer) :start end :end (buffer-gap-start buffer) :from-end t))) - (position target (buffer-data buffer) :start end :end start :from-end t))) - (if start - (setf last (+ start 1) ; match emacs functionality - count (1+ count) - shortage (1- shortage)) - (setf start end))) - (if (zerop count) - (values (and last (buffer-aref-to-char buffer last)) 0) - (values (buffer-aref-to-char buffer end) shortage)))) - -(defun find-before-next-newline (from to cnt) - "Like find_next_newline, but returns position before the newline, -not after, and only search up to TO. This isn't just -find_next_newline (...)-1, because you might hit TO." - (multiple-value-bind (pos shortage) (scan-buffer (current-buffer) #\Newline from to cnt) - (when (zerop shortage) - (decf pos)) - pos)) - -(defun buffer-scan-newline (buf start limit count) - "Search BUF for COUNT newlines with a limiting point at LIMIT, -starting at START. Returns the point of the last newline or limit and -number of newlines found. START and LIMIT are inclusive." - (declare (type buffer buf) - (type integer start limit count)) - (labels ((buffer-scan-bk (buf start limit count) - "count is always >=0. start >= limit." - (let* ((start-aref (buffer-char-to-aref buf start)) - (limit-aref (buffer-char-to-aref buf limit)) - (ceiling (if (>= start-aref (gap-end buf)) - (max limit-aref (gap-end buf)) - limit-aref)) - (i 0) - ;; :END is not inclusive but START is. - (start (1+ start-aref)) - p) - (loop - ;; Always search at least once - (setf p (position #\Newline (buffer-data buf) - :start ceiling :end start :from-end t)) - (if p - (progn - ;; Move start. Note that start isn't set to (1+ p) - ;; because we don't want to search p again. - (setf start p) - ;; Count the newline - (incf i) - ;; Have we found enough newlines? - (when (>= i count) - (return-from buffer-scan-bk (values (buffer-aref-to-char buf p) - i)))) - ;; Check if we've searched up to the limit - (if (= ceiling limit-aref) - (return-from buffer-scan-bk (values limit i)) - ;; if not, skip past the gap - (progn - (setf ceiling limit-aref) - (setf start (buffer-gap-start buf)))))))) - (buffer-scan-fw (buf start limit count) - "count is always >=0. start >= limit." - (let* ((start-aref (buffer-char-to-aref buf start)) - (limit-aref (1+ (buffer-char-to-aref buf limit))) - (ceiling (if (< start (buffer-gap-start buf)) - (min limit-aref (buffer-gap-start buf)) - limit-aref)) - (i 0) - (start start-aref) - p) - (loop - ;; Always search at least once - (setf p (position #\Newline (buffer-data buf) :start start :end ceiling)) - (if p - (progn - ;; Move start. We don't want to search p again, thus the 1+. - (setf start (1+ p)) - ;; Count the newline - (incf i) - ;; Have we found enough newlines? - (when (>= i count) - (return-from buffer-scan-fw (values (buffer-aref-to-char buf p) - i)))) - ;; Check if we've searched up to the limit - (if (= ceiling limit-aref) - (return-from buffer-scan-fw (values limit i)) - ;; if not, skip past the gap - (progn - (setf ceiling limit-aref) - (setf start (gap-end buf))))))))) - ;; make sure start and limit are within the bounds - (setf start (max 0 (min start (1- (buffer-size buf)))) - limit (max 0 (min limit (1- (buffer-size buf))))) - ;; the search always fails on an empty buffer - (when (= (buffer-size buf) 0) - (return-from buffer-scan-newline (values limit 0))) - (cond ((> count 0) - (dformat +debug-vv+ "scan-fw ~a ~a ~a~%" start limit count) - (buffer-scan-fw buf start limit count)) - ((< count 0) - (dformat +debug-vv+ "scan-bk ~a ~a ~a~%" start limit count) - (buffer-scan-bk buf start limit (abs count))) - ;; 0 means the newline before the beginning of the current - ;; line. We need to handle the case where we are on a newline. - (t - (dformat +debug-vv+ "scan-0 ~a ~a ~a~%" start limit count) - (if (char= (buffer-char-after buf start) #\Newline) - (buffer-scan-bk buf start limit 2) - (buffer-scan-bk buf start limit 1)))))) +(defun set-marker (marker position &optional (buffer (current-buffer))) + ;; remove the marker from its buffer, when appropriate + (when (null position) + (unchain-marker marker) + (return-from set-marker marker)) + ;; XXX handle dead buffers + + ;; normalize pos + (setf (marker-position marker) (min (max position (begv buffer)) (zv buffer))) + + ;; update buffer stuff + (unless (eq (marker-buffer marker) buffer) + (unchain-marker marker) + (setf (marker-buffer marker) buffer) + (chain-marker marker buffer)) + marker) + +(defun copy-marker (marker &optional (type :after)) + "Return a new marker pointing at the same place as MARKER. +If argument is a number, makes a new marker pointing +at that position in the current buffer. +**The optional argument TYPE specifies the insertion type of the new marker; +**see `marker-insertion-type'." + (check-type marker (or marker integer)) + (check-type type marker-insertion-type) + (let ((new (make-marker))) + (set-marker new (ensure-number marker) + (if (typep marker 'marker) + (marker-buffer marker) + (current-buffer))) + (setf (marker-insertion-type new) type) + new)) + +(defun purge-markers (buffer) + "Remove GC'd markers." + (setf (buffer-markers buffer) + (delete-if (lambda (m) + (multiple-value-bind (v c) (weak-pointer-value m) + (declare (ignore v)) + (not c))) + (buffer-markers buffer)))) + +(defun update-markers-del (buffer start size) + ;; FIXME: insertion-type + ;; First get rid of stale markers + (purge-markers buffer) + (dolist (wp (buffer-markers buffer)) + (let ((m (weak-pointer-value wp))) + ;; paranoia, maybe the GC freed some stuff after the marker + ;; purge. + (when m + ;; markers are before the marker-position. + (cond ((>= (marker-position m) (+ start size)) + (decf (marker-position m) size)) + ((> (marker-position m) start) + (setf (marker-position m) start))))))) + +(defun update-markers-ins (buffer start size) + ;; FIXME: insertion-type + ;; First get rid of stale markers + (purge-markers buffer) + (dolist (wp (buffer-markers buffer)) + (let ((m (weak-pointer-value wp))) + ;; markers are before the marker-position. + (when (and m (> (marker-position m) start) + (incf (marker-position m) size)))))) + + +;;; + +(defun inc-buffer-tick (buffer) + "Increment the buffer's ticker." + (incf (buffer-modified-tick buffer))) ;; ;;; more stuff @@ -972,22 +361,13 @@ number of newlines found. START and LIMIT are inclusive." ;; FIXME: this is a parameter for debugging ;; FIXME: be more emacs-like or make it better so we don't just have ;; lambda functions that process data and return a string. -(defparameter *mode-line-format* (list "--:" ;; fake it for hype - (lambda (buffer) - (format nil "~C~C" - ;; FIXME: add read-only stuff - (if (buffer-modified-p buffer) - #\* #\-) - (if (buffer-modified-p buffer) - #\* #\-))) - " " - (lambda (buffer) - (format nil "~12,,,a" (buffer-name buffer))) - " " - (lambda (buffer) - (format nil "(~a)" - (major-mode-name (buffer-major-mode buffer))))) - "The default mode line format.") +(defvar *default-mode-line-format* nil + "Default value of `mode-line-format' for buffers that don't override it. +This is the same as (default-value 'mode-line-format).") + +(define-buffer-local *mode-line-format* nil + "The buffer's mode line format.") +(make-variable-buffer-local '*mode-line-format*) (defgeneric mode-line-format-elem (buffer elem) (:documentation "Given the element found in the buffer mode-line, @@ -1011,7 +391,7 @@ return a string that will be printed in the mode-line.")) (setf (buffer-mode-line-string buffer) (format nil "~{~a~}" (mapcar (lambda (elem) (mode-line-format-elem buffer elem)) - (buffer-mode-line buffer))))) + (buffer-local '*mode-line-format* buffer))))) (defun truncate-mode-line (buffer len) "return the buffers mode-line trunctated to len. If the mode-line is @@ -1021,6 +401,14 @@ shorter than len, it will be padded with -'s." ;;; Buffer query/creation +(defun string-to-vector (s) + "Return a resizable vector containing the elements of the string s." + (declare (string s)) + (make-array (length s) + :initial-contents s + :element-type 'character + :adjustable t)) + (defgeneric get-buffer (name) (:documentation "Return the buffer named NAME. If there is no live buffer named NAME, return NIL.")) @@ -1051,13 +439,13 @@ The value is never nil.")) ;; Currently a buffer has to have a gap ;; of at least size 1. :data (string-to-vector "_") + :major-mode '*fundamental-mode* :gap-start 0 :gap-size 1 - :mode-line *mode-line-format* - :name name - :major-mode *fundamental-mode*))) + :name name))) (set-marker (buffer-point b) 0 b) (set-marker (mark-marker b) 0 b) + (setf (buffer-local '*mode-line-format* b) *default-mode-line-format*) (push b *buffer-list*) b)))) @@ -1132,31 +520,6 @@ See also `with-temp-file'." (setf *buffer-list* (delete buf *buffer-list*)) (push buf *buffer-list*)) -(defun other-buffer (&optional (buffer (current-buffer)) visible-ok frame) - "Return most recently selected buffer other than BUFFER. -Buffers not visible in windows are preferred to visible buffers, -unless optional second argument VISIBLE-OK is non-nil. -If the optional third argument FRAME is non-nil, use that frame's -buffer list instead of the selected frame's buffer list. -If no other buffer exists, the buffer `*scratch*' is returned. -If BUFFER is omitted or nil, some interesting buffer is returned." - (declare (ignore frame)) - ;; TODO: honour FRAME argument - (let* (vis - (match (loop for b in *buffer-list* - unless (or (eq b buffer) - (char= (char (buffer-name b) 0) #\Space)) - if (and (not visible-ok) - (get-buffer-window b)) - do (setf vis b) - else return b))) - (or match - vis - (get-buffer-create "*scratch*")))) - -(define-buffer-local *mark-active* nil - "Non-nil means the mark and region are currently active in this buffer.") - (defun mark (&optional force (buffer (current-buffer))) "Return BUFFER's mark value as integer; error if mark inactive. If optional argument FORCE is non-nil, access the mark value @@ -1189,14 +552,6 @@ If START or END are marks, their positions will be used." (signal 'args-out-of-range)) (values start end)) -(defun eobp (&optional (buffer (current-buffer))) - "Return T when the point is at the end of the buffer." - (= (buffer-max buffer) (point))) - -(defun bobp (&optional (buffer (current-buffer))) - "Return T when the point is at the beginning of the buffer." - (= (buffer-min buffer) (point))) - (defun set-buffer (buffer) "Make the buffer BUFFER current for editing operations. BUFFER may be a buffer or the name of an existing buffer. @@ -1265,45 +620,19 @@ To interactively change the default directory, use command `cd'.") ;; (remhash k (buffer-local-variables buffer))))) ;; (maphash #'set-it (buffer-local-variables buffer)))) -;;; reading from the buffer - -(defun read-from-buffer (&aux (buffer (current-buffer))) - "Read 1 sexp from the buffer at the current point, moving the point to the end of what was read" - (when (< (buffer-char-to-aref buffer (point buffer)) - (buffer-gap-start buffer)) - (gap-move-to-point buffer)) - (multiple-value-bind (obj pos) - (read-from-string (buffer-data buffer) t nil - :start (buffer-char-to-aref buffer (point buffer))) - (set-point (buffer-aref-to-char buffer pos)) - obj)) - -(defun set-major-mode (mm) - "Set the current buffer's major mode." - ;; Call All inherited init functions - (mapc (lambda (m) - (set-major-mode (symbol-value m))) (major-mode-inherit-init mm)) - - ;; Now call this mm's init function - (when (major-mode-init mm) - (funcall (major-mode-init mm))) - - ;; Finally, set the mode and call the hook - (setf (buffer-major-mode (current-buffer)) mm) - (run-hooks (major-mode-hook mm))) - (defun major-mode () - (buffer-major-mode (current-buffer))) + (symbol-value (buffer-major-mode (current-buffer)))) (define-buffer-local *fill-column* 70 "*Column beyond which automatic line-wrapping should happen. Interactively, you can set the buffer local value using \\[set-fill-column].") -(defun buffer-list (&optional (frame (selected-frame))) +(defun buffer-list (&optional frame) "Return a list of all existing live buffers. If the optional arg frame is a frame, we return the buffer list in the proper order for that frame: the buffers in FRAME's `buffer-list' frame parameter come first, followed by the rest of the buffers." + ;; FIXME: handle frame (declare (ignore frame)) *buffer-list*) @@ -1328,4 +657,32 @@ its value may not be a list of functions.") Linefeed indents to this column in Fundamental mode.") (make-variable-buffer-local 'left-margin) +(defun make-buffer-string (start end props &optional (buffer (current-buffer))) + "Making strings from buffer contents. + +Return a Lisp_String containing the text of the current buffer from +START to END. If text properties are in use and the current buffer has +properties in the range specified, the resulting string will also have +them, if PROPS is nonzero. + +We don't want to use plain old make_string here, because it calls +make_uninit_string, which can cause the buffer arena to be +compacted. make_string has no way of knowing that the data has +been moved, and thus copies the wrong data into the string. This +doesn't effect most of the other users of make_string, so it should +be left as is. But we should use this function when conjuring +buffer substrings." + (declare (ignore props)) + ;; If the gap intersects with the range we wanna grab, move it. + (if (= start end) + "" + (progn + (when (and (< start (buffer-gap-start buffer)) + (< (buffer-gap-start buffer) end)) + (gap-move-to buffer start)) + (dformat +debug-v+ "substring: ~a ~a ~a~%" start end (length (buffer-data buffer))) + (subseq (buffer-data buffer) + (buffer-char-to-aref buffer start) + (1+ (buffer-char-to-aref buffer (1- end))))))) + (provide :lice-0.1/buffer) diff --git a/clisp-render.lisp b/clisp-render.lisp index c2effa6..d7fcbb1 100644 --- a/clisp-render.lisp +++ b/clisp-render.lisp @@ -185,7 +185,7 @@ the text properties present." :width cols :height lines :window-tree (list w mb) - :current-window w + :selected-window w :minibuffer-window mb :window-stream ws :double-buffer l diff --git a/cmds.lisp b/cmds.lisp new file mode 100644 index 0000000..768d4ed --- /dev/null +++ b/cmds.lisp @@ -0,0 +1,98 @@ +;;; Simple built-in editing commands. + +(in-package "LICE") + +(defun forward-point (n) + "Return buffer position N characters after (before if N negative) point." + (check-type n integer) + (+ (pt) n)) + +(defcommand forward-char ((&optional (n 1)) + :prefix) + "Move the point forward N characters in the current buffer." + (incf (marker-position (buffer-point (current-buffer))) n) + (cond ((< (pt) (begv)) + (set-point (begv)) + (signal 'beginning-of-buffer)) + ((> (pt) (zv)) + (set-point (zv)) + (signal 'end-of-buffer)))) + +(defcommand backward-char ((&optional (n 1)) + :prefix) + (forward-char (- n))) + +(defun forward-line (n) + "Move n lines forward (backward if n is negative). +Precisely, if point is on line I, move to the start of line I + n. +If there isn't room, go as far as possible (no error). +Returns the count of lines left to move. If moving forward, +that is n - number of lines moved; if backward, n + number moved. +With positive n, a non-empty line at the end counts as one line + successfully moved (for the return value)." + (cond ((and (> n 0) + (= (pt) (zv))) + (signal 'end-of-buffer)) + ((and (< n 0) + (= (pt) (begv))) + (signal 'beginning-of-buffer))) + (if (> n 0) + (multiple-value-bind (p lines) (buffer-scan-newline (current-buffer) + (pt) + (1- (buffer-size (current-buffer))) + n) + ;; Increment p by one so the point is at the beginning of the + ;; line. + (when (or (char= (buffer-char-after (current-buffer) p) #\Newline) + (= p (1- (buffer-size (current-buffer))))) + (incf p)) + (set-point p) + (when (zerop lines) + (signal 'end-of-buffer)) + (- n lines)) + (if (and (= n 0) + (not (buffer-char-before (current-buffer) (pt)))) + 0 + ;; A little mess to figure out how many newlines to search + ;; for to give the proper output. + (let ((lines (if (and (buffer-char-after (current-buffer) (pt)) + (char= (buffer-char-after (current-buffer) (pt)) #\Newline)) + (- n 2) + (1- n)))) + (multiple-value-bind (p flines) + (buffer-scan-newline (current-buffer) + (pt) (begv) + lines) + (when (and (char= (buffer-char-after (current-buffer) p) #\Newline) + (= flines (- lines))) + (incf p)) + (set-point p) + (when (and (< n 0) + (zerop flines)) + (signal 'beginning-of-buffer)) + (+ n flines)))))) + +(defun beginning_of_line () + (error "unimplemented")) + +(defun end_of_line () + (error "unimplemented")) + +(defcommand delete-char () + "Delete the following N characters." + (buffer-delete (current-buffer) (pt) 1)) + +(defcommand delete-backward-char () + "Delete the previous N characters." + (buffer-delete (current-buffer) (pt) -1)) + +(defcommand self-insert-command ((arg) + :prefix) + "Insert the character you type. +Whichever character you type to run this command is inserted." + (dformat +debug-v+ "currentb: ~a ~a~%" (current-buffer) *current-buffer*) + (if (>= arg 2) + (insert-move-point (current-buffer) (make-string arg :initial-element (key-char *current-event*))) + (when (> arg 0) + (insert-move-point (current-buffer) (key-char *current-event*))))) + diff --git a/commands.lisp b/commands.lisp index 7718382..021a3c2 100644 --- a/commands.lisp +++ b/commands.lisp @@ -2,6 +2,17 @@ (in-package "LICE") +(defvar *prefix-arg* nil + "The value of the prefix argument for the next editing command. +It may be a number, or the symbol `-' for just a minus sign as arg, +or a list whose car is a number for just one or more C-u's +or nil if no argument has been specified. + +You cannot examine this variable to find the argument for this command +since it has been set to nil by the time you can look. +Instead, you should use the variable `current-prefix-arg', although +normally commands can get this prefix argument with (interactive \"P\").") + (defclass command () ((name :type symbol :initarg :name :accessor command-name) (args :type list :initarg :args :accessor command-args) diff --git a/debug.lisp b/debug.lisp index d9fd810..d887d02 100644 --- a/debug.lisp +++ b/debug.lisp @@ -1,6 +1,6 @@ ;;; lice debugging facilities -(in-package :lice) +(in-package "LICE") (defun re-op-lice (op) "Perform an asdf operation on :lice and capture the output in a diff --git a/debugger.lisp b/debugger.lisp index cd3aaae..548a942 100644 --- a/debugger.lisp +++ b/debugger.lisp @@ -1,6 +1,6 @@ ;;; An interactive debugger for lice -(in-package #:lice) +(in-package "LICE") (defvar *debug-on-error* t "Non-nil means enter the debugger if an unhandled error is signaled.") @@ -16,7 +16,7 @@ m))) (defun debugger-mode () "See `*debugger-mode*'" - (set-major-mode *debugger-mode*)) + (set-major-mode '*debugger-mode*)) (defun enter-debugger (condition old-debugger-value) "Create a debugger buffer, print the error and any active restarts." @@ -28,10 +28,10 @@ (setf *quit-flag* t) (continue)) ;; make sure we're not in the minibuffer - (select-window (first (frame-window-list *current-frame*))) + (select-window (first (frame-window-list (selected-frame)))) (pop-to-buffer (get-buffer-create "*debugger*")) (erase-buffer) - (set-major-mode *debugger-mode*) + (set-major-mode '*debugger-mode*) (insert (format nil "Debugger~%~a~%~%~a~%~{~a~%~}" (backtrace-as-string) condition (compute-restarts))) (recursive-edit) ;; if we exit the recursive edit we'll fall into the regular debugger. diff --git a/doctor.lisp b/doctor.lisp index 4738ed1..be8b184 100644 --- a/doctor.lisp +++ b/doctor.lisp @@ -128,7 +128,7 @@ reads the sentence before point, and prints the Doctor's answer.") (defcommand doctor-mode () "See `*doctor-mode*'." - (set-major-mode *doctor-mode*)) + (set-major-mode '*doctor-mode*)) (defun make-doctor-variables () (make-local-variable 'typos) @@ -922,7 +922,7 @@ Otherwise call the Doctor to parse preceding sentence." ;; Main processing function for sentences that have been read. -(declaim (special sent)) +;;(declaim (special sent)) (defun doctor-doc (sent) ;; Old emacs programs actually depended on dynamic scope! @@ -1061,7 +1061,7 @@ Put dialogue in buffer." (insert #\Newline prompt (read-string prompt) - \Newline) + #\Newline) (setq a (doctor-readin))) (while (and a (not retval)) (cond ((doctor-nounp (car a)) diff --git a/editfns.lisp b/editfns.lisp index 0683f24..984b3b6 100644 --- a/editfns.lisp +++ b/editfns.lisp @@ -1,4 +1,4 @@ -(in-package :lice) +(in-package "LICE") (defvar *inhibit-field-text-motion* nil "Non-nil means text motion commands don't notice fields.") @@ -74,7 +74,7 @@ is not stored." (at-field-end nil) before-field after-field) (unless pos - (setf pos (point))) + (setf pos (pt))) (setf after-field (get-char-property-and-overlay pos 'field buf nil) before-field (if (> pos (begv buf)) (get-char-property-and-overlay (1- pos) 'field buf nil) @@ -144,34 +144,6 @@ is not stored." (or pos (zv buf)))))))) -(defun make-buffer-string (start end props &optional (buffer (current-buffer))) - "Making strings from buffer contents. - -Return a Lisp_String containing the text of the current buffer from -START to END. If text properties are in use and the current buffer has -properties in the range specified, the resulting string will also have -them, if PROPS is nonzero. - -We don't want to use plain old make_string here, because it calls -make_uninit_string, which can cause the buffer arena to be -compacted. make_string has no way of knowing that the data has -been moved, and thus copies the wrong data into the string. This -doesn't effect most of the other users of make_string, so it should -be left as is. But we should use this function when conjuring -buffer substrings." - (declare (ignore props)) - ;; If the gap intersects with the range we wanna grab, move it. - (if (= start end) - "" - (progn - (when (and (< start (buffer-gap-start buffer)) - (< (buffer-gap-start buffer) end)) - (gap-move-to buffer start)) - (dformat +debug-v+ "substring: ~a ~a ~a~%" start end (length (buffer-data buffer))) - (subseq (buffer-data buffer) - (buffer-char-to-aref buffer start) - (1+ (buffer-char-to-aref buffer (1- end))))))) - (defun buffer-substring (start end &optional (buffer (current-buffer))) "Return the contents of part of the current buffer as a string. The two arguments START and END are character positions; @@ -256,7 +228,7 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil." fwd prev-old prev-new) (unless new-pos ;; Use the current point, and afterwards, set it. - (setf new-pos (point) + (setf new-pos (pt) orig-point new-pos)) (check-type new-pos number) (check-type old-pos number) @@ -337,6 +309,23 @@ the stretch to be deleted." (multiple-value-setq (start end) (validate-region start end buffer)) (buffer-delete buffer start (- end start))) +(defun point (&aux (buffer (current-buffer))) + "Return the point in the current buffer." + (pt buffer)) + +(defun point-marker (&aux (buffer (current-buffer))) + "Return value of point, as a marker object." + (buffer-point buffer)) + +(defun point-min (&aux (buffer (current-buffer))) + "Return the minimum permissible value of point in the current buffer." + (declare (ignore buffer)) + 0) + +(defun point-max (&aux (buffer (current-buffer))) + "Return the maximum permissible value of point in the current buffer." + (buffer-size buffer)) + (defmacro save-current-buffer (&body body) "Save the current buffer; execute BODY; restore the current buffer. Executes BODY just like `progn'." @@ -369,6 +358,24 @@ even in case of abnormal exit (throw or error). (setf (buffer-mark-marker ,cb) ,mark (buffer-point ,cb) ,point)))))) +(defun insert (&rest objects) + "Insert the arguments, either strings or characters, at point. +Point and before-insertion markers move forward to end up + after the inserted text. +Any other markers at the point of insertion remain before the text. + +If the current buffer is multibyte, unibyte strings are converted +to multibyte for insertion (see `string-make-multibyte'). +If the current buffer is unibyte, multibyte strings are converted +to unibyte for insertion (see `string-make-unibyte'). + +When operating on binary data, it may be necessary to preserve the +original bytes of a unibyte string when inserting it into a multibyte +buffer; to accomplish this, apply `string-as-multibyte' to the string +and insert the result." + (dolist (o objects) + (insert-move-point (current-buffer) o))) + (defun insert-buffer-substring (buffer start end) "Insert before point a substring of the contents of buffer. buffer may be a buffer or a buffer name. @@ -382,27 +389,35 @@ They default to the values of (point-min) and (point-max) in buffer." (defun preceding-char () "Return the character preceding point. At the beginning of the buffer or accessible region, return #\Nul." - (or (char-before (point)) + (or (buffer-char-before (current-buffer) (pt)) #\Nul)) (defun following-char () "Return the character following point, as a number. At the end of the buffer or accessible region, return #\Nul." - (if (>= (point) (zv)) + (if (>= (pt) (zv)) #\Nul ; XXX return nil? - (buffer-fetch-char (buffer-char-to-aref (current-buffer) (point)) + (buffer-fetch-char (buffer-char-to-aref (current-buffer) (pt)) (current-buffer)))) (defun bolp () "Return t if point is at the beginning of a line." - (or (= (point) (point-min)) - (char= (char-before (point)) #\Newline))) + (or (= (pt) (begv)) + (char= (buffer-char-before (current-buffer) (pt)) #\Newline))) (defun eolp () "Return t if point is at the end of a line. `End of a line' includes point being at the end of the buffer." - (or (= (point) (point-max)) - (char= (char-after (point)) #\Newline))) + (or (= (pt) (zv)) + (char= (buffer-char-after (current-buffer) (pt)) #\Newline))) + +(defun bobp (&optional (buffer (current-buffer))) + "Return T when the point is at the beginning of the buffer." + (= (begv buffer) (pt))) + +(defun eobp (&optional (buffer (current-buffer))) + "Return T when the point is at the end of the buffer." + (= (zv buffer) (pt))) (defun delete-and-extract-region (start end) "Delete the text between start and end and return it." @@ -440,8 +455,8 @@ This function does not move point." ;; FIXME: inhibit-point-motion-hooks (let ((pt (save-excursion (forward-line (if n (1- n) 0)) - (point)))) - (constrain-to-field pt (point) (not (eql n 1)) t nil))) + (pt)))) + (constrain-to-field pt (pt) (not (eql n 1)) t nil))) (defun line-end-position (&optional (n 1)) "Return the character position of the last character on the current line. @@ -457,15 +472,17 @@ boundaries bind `inhibit-field-text-motion' to t. This function does not move point." (check-type n integer) (setf n (- n (if (<= n 0) 1 0))) - (let* ((orig (point)) + (let* ((orig (pt)) (end-pos (find-before-next-newline orig nil n))) (constrain-to-field end-pos orig nil t nil))) (defun clip-to-bounds (lower num upper) (max (min num upper) lower)) -(defun string-to-char () - (error "Unimplemented")) +(defun string-to-char (string) + "Convert arg string to a character, the first character of that string. +A multibyte character is handled correctly." + (char string 0)) (defun char-to-string () (error "Unimplemented")) @@ -590,4 +607,25 @@ This function does not move point." (defun transpose-regions () (error "Unimplemented")) +(defun goto-char (position &aux (buffer (current-buffer))) + "Set point to POSITION, a number." + (check-number-coerce-marker position) + (when (and (>= position (begv buffer)) + (<= position (zv buffer))) + (set-point position buffer))) + +(defun char-after (&optional (pos (pt))) + "Return character in current buffer at position POS. +***POS is an integer or a marker. +***If POS is out of range, the value is nil." + (check-number-coerce-marker pos) + (buffer-char-after (current-buffer) pos)) + +(defun char-before (&optional (pos (pt))) + "Return character in current buffer preceding position POS. +***POS is an integer or a marker. +***If POS is out of range, the value is nil." + (check-number-coerce-marker pos) + (buffer-char-after (current-buffer) (1- pos))) + (provide :lice-0.1/editfns) diff --git a/files.lisp b/files.lisp index 0c8dac6..07d6240 100644 --- a/files.lisp +++ b/files.lisp @@ -67,12 +67,11 @@ from `mode-require-final-newline'." :point (make-marker) :mark (make-marker) :data data - :mode-line *mode-line-format* :name (format-filename filename) ;; 1- because the data has been allocated with 1 extra character :gap-start (1- (length data)) :gap-size 1 ;;(length +other-buf+) - :major-mode *fundamental-mode*))) + :major-mode '*fundamental-mode*))) (set-marker (buffer-point b) 0 b) (set-marker (mark-marker b) 0 b) b)) @@ -83,15 +82,13 @@ from `mode-require-final-newline'." ;; check that the directory exists (unless (ensure-directories-exist pn) (error "dir doesn't exist")) - (if (probe-file pn) - (let ((b (make-file-buffer pn))) - (push b *buffer-list*) - b) - ;; It doesn't exist so open an empty buffer but give it a file, - ;; so it can be saved. - (let ((b (get-buffer-create (format-filename pn)))) - (setf (buffer-file b) pn) - b)))) + (let ((b (get-buffer-create (format-filename pn)))) + (setf (buffer-file b) pn) + (when (probe-file pn) + (setf (buffer-data b) (slurp-file pn) + (buffer-gap-start b) (1- (length (buffer-data b))) + (buffer-gap-size b) 1)) + b))) (defcommand find-file ((filename) (:file "Find File: ")) diff --git a/frame.lisp b/frame.lisp dissimilarity index 86% index 71ce20a..5f6dba6 100644 --- a/frame.lisp +++ b/frame.lisp @@ -1,286 +1,181 @@ -(in-package :lice) - -(defvar *frame-list* nil - "List of frames lice frames.") - -;; XXX: This is only temporary -(defvar *current-frame* nil - "The frame that accepts input.") - -(defun selected-frame () - "Return the frame that is now selected." - *current-frame*) - -(defclass frame () - ((window-tree :type (or list window) :initarg :window-tree :accessor frame-window-tree) - (width :type fixnum :initarg :width :accessor frame-width) - (height :type fixnum :initarg :height :accessor frame-height) - (minibuffer-window :type window :initarg :minibuffer-window :accessor frame-minibuffer-window) - (minibuffers-active :type fixnum :initform 0 :initarg minibuffers-active :accessor frame-minibuffers-active) - (current-window :type window :initarg :current-window :accessor frame-current-window)) - (:documentation "A Lice frame is super cool.")) - -(defun set-frame-minibuffer (frame minibuffer) - "Make MINIBUFFER the minibuffer for FRAME." - (setf (window-buffer (frame-minibuffer-window frame)) minibuffer)) - -;; The defmethods are found in the *-render.lisp files -(defgeneric frame-start-render (frame) - (:documentation "Do any setup we need before we beginning rendering the frame.")) - -(defgeneric frame-end-render (frame) - (:documentation "Do any cleanup or refreshing after the frame is rendered.")) - -;; the defmethods are found in the *-render.lisp files -(defgeneric window-render (window frame) - (:documentation "Render the window in the given frame.")) - -(defgeneric frame-read-event (frame) - (:documentation "Read a keyboard event for the specified frame.")) - -(defgeneric frame-move-cursor (frame window x y) - (:documentation "Move the cursor to the X,Y location in WINDOW on the frame, FRAME.")) - -(defun frame-render (frame) - "Render a frame." - (let (cursor-x cursor-y win) - (labels ((render (tree) - (cond ((null tree) nil) - ((atom tree) - ;; reset the cache - (window-reset-cache tree) - ;; Figure out what part to display - (window-framer tree - (window-point tree) - (truncate (window-height tree) 2)) - (dformat +debug-vvv+ "after framer: ~a~%" - (lc-cache (window-cache tree))) - ;; display it - (multiple-value-bind (x y) (window-render tree frame) - (when (eq tree (frame-current-window frame)) - (setf win tree cursor-x x cursor-y y)))) - (t (cons (render (car tree)) - (render (cdr tree))))))) - (frame-start-render frame) - (render (frame-window-tree frame)) - (when (and win cursor-x cursor-y) - (frame-move-cursor frame win cursor-x cursor-y)) - (frame-end-render frame)))) - - -(defun resize-window (window amount &optional (dir :height)) - "grow or shrink window, resizing dependant windows as well." - (declare (ignore window amount dir)) -;; (let* ((frame (frame-window-tree (frame-for-window window))) -;; (sibling (tree-sibling frame window))) -;; ) - ) - -(defun current-buffer () - "Return the current buffer." - ;; FIXME: maybe this should just return *current-buffer* - (or *current-buffer* - ;;(window-buffer (frame-current-window (selected-frame))) - )) - -(defun active-minibuffer-window () - "Return the currently active minibuffer window or nil if there isn't -one." - (let ((frame (selected-frame))) - (unless (zerop (frame-minibuffers-active frame)) - (frame-minibuffer-window frame)))) - -(defun frame-window-list (frame &optional minibuf) - "Return the list of windows in FRAME. If MINIBUF is true then include the minibuffer window." -;; (declare (type frame frame)) - ;; FIXME: The reason we need to pass MB into flatten is because movitz can't "lend optional right now" - (labels ((flatten (tree mb) - (if (atom tree) - (unless (and (typep tree 'minibuffer-window) - (not mb)) - (list tree)) - (nconc (flatten (first tree) mb) - (flatten (second tree) mb))))) - (flatten (frame-window-tree frame) minibuf))) - -(defun window-tree-find-if (fn tree &optional minibuf) - "depth first search the tree. Return the element that satisfies FN." - (cond ((listp tree) - (loop for i in tree - thereis (window-tree-find-if fn i minibuf))) - ((typep tree 'minibuffer-window) - (when (and minibuf - (funcall fn tree)) - tree)) - (t - (when (funcall fn tree) - tree)))) - -(defun replace-window-in-frame-tree (window new) - (labels ((doit (tree window new) - (let ((p (position window tree))) - (if p - (setf (nth p tree) new) - (loop for w in tree - until (and (listp w) - (doit w window new))))))) - (doit (frame-window-tree (window-frame window)) - window - new))) - -;; (defun replace-window-parent-in-frame-tree (window new) -;; (labels ((doit (tree parent window new) -;; (when (listp tree) -;; (let (loop for i in (remove-if-not 'listp tree) -;; thereis (find window i)) -;; (parent -;; ( -;; ))) -;; (doit (frame-window-tree (window-frame window)) -;; window -;; new))) - -(defun split-window (&optional (window (get-current-window)) size horflag) - (when (typep window 'minibuffer-window) - (error "Attempt to split minibuffer window")) - (when (null size) - (setf size (if horflag - (ceiling (window-width window t) 2) - (ceiling (window-height window t) 2)))) - (let (new) - (if horflag - (progn - (when (< size *window-min-width*) - (error "Window width ~a too small (after splitting)" size)) - ;; will the other window be too big? - (when (> (+ size *window-min-width*) - (window-width window t)) - (error "Window width ~a too small (after splitting)" (- (window-width window t) size))) - (setf new (make-window :x (+ (window-x window) size) - :y (window-y window) - :cols (- (window-width window t) size) - :rows (window-height window t) - :buffer (window-buffer window) - :frame (window-frame window)) - (window-seperator new) (window-seperator window) - (window-seperator window) t - (slot-value window 'w) size) - ;;(update-window-display-arrays window) - ) - (progn - (when (< size *window-min-height*) - (error "Window height ~a too small (after splitting)" size)) - ;; will the other window be too big? - (when (> (+ size *window-min-height*) - (window-height window t)) - (error "Window width ~a too small (after splitting)" (- (window-height window t) size))) - (setf new (make-window :x (window-x window) - :y (+ (window-y window) size) - :cols (window-width window t) - :rows (- (window-height window t) size) - :buffer (window-buffer window) - :frame (window-frame window)) - (window-seperator new) (window-seperator window) - (slot-value window 'h) size) - ;;(update-window-display-arrays window) - )) - (replace-window-in-frame-tree window (list window new)) - new)) - -(defun next-window (window &optional minibuf) - "Return next window after WINDOW in canonical ordering of windows. -FIXME: make this the same as Emacs' next-window." - (let* ((frame (window-frame window)) - (tree (frame-window-tree frame)) - bit - ;; when we find WINDOW, set BIT to T and return the next window. - (w (window-tree-find-if (lambda (w) - (cond (bit w) - ((eq w window) - (setf bit t) - nil))) - tree - (and minibuf (> (frame-minibuffers-active frame) 0))))) - ;; if we didn't find the next one, maybe it's the first one - (if (not w) - (let ((other (window-tree-find-if #'identity tree))) - (unless (eq window other) - other)) - w))) - - -(defun select-window (window &optional norecord) - "Select WINDOW. Most editing will apply to WINDOW's buffer. -If WINDOW is not already selected, also make WINDOW's buffer current. -Also make WINDOW the frame's selected window. -Optional second arg NORECORD non-nil means -do not put this buffer at the front of the list of recently selected ones. - -**Note that the main editor command loop -**selects the buffer of the selected window before each command." - (declare (ignore norecord)) - ;; FIXME: get NORECORD working - (window-save-point (get-current-window)) - ;; FIXME: this doesn't make sure window-frame is current. - (setf (frame-current-window (window-frame window)) window) - (set-buffer (window-buffer window)) - (window-restore-point window)) - -(defun display-buffer (buffer &optional not-this-window frame) - "Make BUFFER appear in some window but don't select it. -BUFFER can be a buffer or a buffer name. -If BUFFER is shown already in some window, just use that one, -unless the window is the selected window and the optional second -argument NOT-THIS-WINDOW is non-nil (interactively, with prefix arg). -**If `pop-up-frames' is non-nil, make a new frame if no window shows BUFFER. -**Returns the window displaying BUFFER. -**If `display-buffer-reuse-frames' is non-nil, and another frame is currently -**displaying BUFFER, then simply raise that frame." - (declare (ignore frame)) - (setf buffer (get-buffer buffer)) - (let* ((cw (get-current-window)) - (w (or (window-tree-find-if (lambda (w) - (and (not (and not-this-window - (eq w cw))) - (eq (window-buffer w) buffer))) - (frame-window-tree (selected-frame))) - (next-window cw) - (split-window cw)))) - (set-window-buffer w buffer) - (window-restore-point w) - w)) - -(defun pop-to-buffer (buffer &optional other-window norecord) - "Select buffer BUFFER in some window, preferably a different one. -If `pop-up-windows' is non-nil, windows can be split to do this. -If optional second arg OTHER-WINDOW is non-nil, insist on finding another -window even if BUFFER is already visible in the selected window. -This uses the function `display-buffer' as a subroutine; see the documentation -of `display-buffer' for additional customization information. - -**Optional third arg NORECORD non-nil means -**do not put this buffer at the front of the list of recently selected ones." - (declare (ignore norecord)) - ;; FIXME: honour NORECORD - (setf buffer (if buffer - (or (get-buffer buffer) - (progn - (get-buffer-create buffer))) - ;; FIXME: (set-buffer-major-mode buffer) - (other-buffer (current-buffer)))) - (select-window (display-buffer buffer other-window))) - -(defun sit-for (seconds &optional nodisp) - "Perform redisplay, then wait for seconds seconds or until input is available. -seconds may be a floating-point value, meaning that you can wait for a -fraction of a second. - (Not all operating systems support waiting for a fraction of a second.) -Optional arg nodisp non-nil means don't redisplay, just wait for input. -Redisplay is preempted as always if input arrives, and does not happen -if input is available before it starts. -Value is t if waited the full time with no input arriving." - (declare (ignore seconds nodisp)) - ;; FIXME: actually sleep - (frame-render (selected-frame))) - -(provide :lice-0.1/frame) +(in-package :lice) + +(defvar *frame-list* nil + "List of frames lice frames.") + +(defun set-frame-minibuffer (frame minibuffer) + "Make MINIBUFFER the minibuffer for FRAME." + (setf (window-buffer (frame-minibuffer-window frame)) minibuffer)) + +(defun resize-window (window amount &optional (dir :height)) + "grow or shrink window, resizing dependant windows as well." + (declare (ignore window amount dir)) +;; (let* ((frame (frame-window-tree (frame-for-window window))) +;; (sibling (tree-sibling frame window))) +;; ) + ) + +(defun selected-frame () + "Return the frame that is now selected." + *selected-frame*) + +(defun active-minibuffer-window () + "Return the currently active minibuffer window or nil if there isn't +one." + (let ((frame (selected-frame))) + (unless (zerop (frame-minibuffers-active frame)) + (frame-minibuffer-window frame)))) + +(defun frame-window-list (frame &optional minibuf) + "Return the list of windows in FRAME. If MINIBUF is true then include the minibuffer window." +;; (declare (type frame frame)) + ;; FIXME: The reason we need to pass MB into flatten is because movitz can't "lend optional right now" + (labels ((flatten (tree mb) + (if (atom tree) + (unless (and (typep tree 'minibuffer-window) + (not mb)) + (list tree)) + (nconc (flatten (first tree) mb) + (flatten (second tree) mb))))) + (flatten (frame-window-tree frame) minibuf))) + +(defun framep (object) + "Return non-nil if OBJECT is a frame. +Value is t for a termcap frame (a character-only terminal), +`x' for an Emacs frame that is really an X window, +`w32' for an Emacs frame that is a window on MS-Windows display, +`mac' for an Emacs frame on a Macintosh display, +`pc' for a direct-write MS-DOS frame. +See also `frame-live-p'." + (typep object 'frame)) + +(defun frame-live-p () + (error "unimplemented")) + +(defun make-terminal-frame () + (error "unimplemented")) + +(defun handle-switch-frame () + (error "unimplemented")) + +(defun select-frame (frame) + "Select the frame FRAME. +Subsequent editing commands apply to its selected window. +The selection of FRAME lasts until the next time the user does +something to select a different frame, or until the next time this +function is called. If you are using a window system, the previously +selected frame may be restored as the selected frame after return to +the command loop, because it still may have the window system's input +focus. On a text-only terminal, the next redisplay will display FRAME. + +This function returns FRAME, or nil if FRAME has been deleted." + (declare (ignore frame)) + (error "unimplemented")) + +(defun frame-root-window () + (error "unimplemented")) + +(defun frame-first-window () + (error "unimplemented")) + +(depricate set-frame-selected-window (setf frame-selected-window)) +(defun set-frame-selected-window (frame window) + "Set the selected window of frame object frame to window. +Return window. +If frame is nil, the selected frame is used. +If frame is the selected frame, this makes window the selected window." + (setf (frame-selected-window (or frame (selected-frame))) window)) + +(defun frame-list () + "Return a list of all frames." + (copy-list *frame-list*)) + +(defun next-frame () + (error "unimplemented")) + +(defun previous-frame () + (error "unimplemented")) + +(defun delete-frame () + (error "unimplemented")) + +(defun mouse-position () + (error "unimplemented")) + +(defun mouse-pixel-position () + (error "unimplemented")) + +(defun set-mouse-position () + (error "unimplemented")) + +(defun set-mouse-pixel-position () + (error "unimplemented")) + +(defun make-frame-visible () + (error "unimplemented")) + +(defun make-frame-invisible () + (error "unimplemented")) + +(defun iconify-frame () + (error "unimplemented")) + +(defun frame-visible-p () + (error "unimplemented")) + +(defun visible-frame-list () + (error "unimplemented")) + +(defun raise-frame () + (error "unimplemented")) + +(defun lower-frame () + (error "unimplemented")) + +(defun redirect-frame-focus () + (error "unimplemented")) + +(defun frame-focus () + (error "unimplemented")) + +(defun frame-parameters () + (error "unimplemented")) + +(defun frame-parameter () + (error "unimplemented")) + +(defun modify-frame-parameters () + (error "unimplemented")) + +(defun frame-char-height () + (error "unimplemented")) + +(defun frame-char-width () + (error "unimplemented")) + +(defun frame-pixel-height () + (error "unimplemented")) + +(defun frame-pixel-width () + (error "unimplemented")) + +(defun set-frame-height () + (error "unimplemented")) + +(defun set-frame-width () + (error "unimplemented")) + +(defun set-frame-size () + (error "unimplemented")) + +(defun set-frame-position () + (error "unimplemented")) + + +;; (defun x-get-resource () +;; (error "unimplemented")) + +;; (defun x-parse-geometry () +;; (error "unimplemented")) + +(provide :lice-0.1/frame) diff --git a/global.lisp b/global.lisp index a016957..7b3f8a8 100644 --- a/global.lisp +++ b/global.lisp @@ -72,14 +72,6 @@ until TEST returns nil." `(loop while ,test do ,@body) `(loop while ,test))) -(defmacro check-number-coerce-marker (marker-var) - "Verify that MARKER-VAR is a number or if it's a marker then -set the var to the marker's position." - `(progn - (check-type ,marker-var (or number marker)) - (when (typep ,marker-var 'marker) - (setf ,marker-var (marker-position ,marker-var))))) - (defun cdr-safe (object) "Return the cdr of OBJECT if it is a cons cell, or else nil." (when (consp object) @@ -213,9 +205,52 @@ number may be an integer or a floating point number." (check-type n number) (prin1-to-string n)) -(defun string-to-char (string) - "Convert arg string to a character, the first character of that string. -A multibyte character is handled correctly." - (char string 0)) +(defun split-string (string &optional (separators " +")) + "Splits STRING into substrings where there are matches for SEPARATORS. +Each match for SEPARATORS is a splitting point. +The substrings between the splitting points are made into a list +which is returned. +***If SEPARATORS is absent, it defaults to \"[ \f\t\n\r\v]+\". + +If there is match for SEPARATORS at the beginning of STRING, we do not +include a null substring for that. Likewise, if there is a match +at the end of STRING, we don't include a null substring for that. + +Modifies the match data; use `save-match-data' if necessary." + ;; FIXME: This let is here because movitz doesn't 'lend optional' + (let ((seps separators)) + (labels ((sep (c) + (find c seps :test #'char=))) + (loop for i = (position-if (complement #'sep) string) + then (position-if (complement #'sep) string :start j) + while i + as j = (position-if #'sep string :start i) + collect (subseq string i j) + while j)))) + +;; A cheap memoizer. Obviously, a hashtable would be better. + +(defstruct memoize-state + (data (vector nil nil nil nil nil nil nil nil nil nil nil nil)) + (test 'equal) + (pt 0)) + +(defun memoize-store (state thing value) + (incf (memoize-state-pt state)) + (when (> (memoize-state-pt state) + (length (memoize-state-data state))) + (setf (memoize-state-pt state) 0)) + (setf (svref (memoize-state-data state) (memoize-state-pt state)) (cons thing value)) + value) + +(defmacro memoize (mem-var thing compute) + "Check if we've computed a value for thing. if so, use it. if +not compute it, store the result, and return it." + (let ((match (gensym "MATCH"))) + `(let ((,match (find ,thing (memoize-state-data ,mem-var) :key 'first :test (memoize-state-test ,mem-var)))) + (if ,match + (cdr ,match) + (memoize-store ,mem-var ,thing ,compute))))) (provide :lice-0.1/global) diff --git a/help.lisp b/help.lisp index cb60593..75c71d6 100644 --- a/help.lisp +++ b/help.lisp @@ -1,6 +1,6 @@ ;;; Documentation and help related commands -(in-package :lice) +(in-package "LICE") (defcommand describe-symbol () "Display the full documentation of a symbol." diff --git a/indent.lisp b/indent.lisp index b574afd..6917471 100644 --- a/indent.lisp +++ b/indent.lisp @@ -32,7 +32,7 @@ Don't rebind TAB unless you really need to.") "Return the indentation of the current line. This is the horizontal position of the character following any initial whitespace." - (let ((pt (buffer-scan-newline buffer (point buffer) (begv buffer) -1))) + (let ((pt (buffer-scan-newline buffer (pt buffer) (begv buffer) -1))) (position-indentation (buffer-char-to-aref buffer pt) buffer))) ;; (defun current-column () @@ -52,7 +52,7 @@ Whether the line is visible (if `selective-display' is t) has no effect; however, ^M is treated as end of line when `selective-display' is t. Text that has an invisible property is considered as having width 0, unless `buffer-invisibility-spec' specifies that it is replaced by an ellipsis." - (let ((pos-aref (buffer-char-to-aref buffer (point))) + (let ((pos-aref (buffer-char-to-aref buffer (pt buffer))) (column 0) c) (loop diff --git a/insdel.lisp b/insdel.lisp new file mode 100644 index 0000000..4ff9369 --- /dev/null +++ b/insdel.lisp @@ -0,0 +1,159 @@ +;;; buffer inserting, deleting, gap management, etc + +(in-package "LICE") + +;; (defun gap-close (buf) +;; "Move the gap to the end of the buffer." +;; (let ((gap-start (buffer-gap-start buf)) +;; (gap-end (gap-end buf))) +;; (setf (buffer-gap-start buf) (- (length (buffer-data buf)) (buffer-gap-size buf))) +;; (replace (buffer-data buf) (buffer-data buf) :start1 gap-start :start2 gap-end))) + +(defun grow-buffer-data (buf size) + "Grow the buffer data array to be SIZE. SIZE must be larger than before." + ;; MOVITZ doesn't have adjust-array + ;; ;; #\_ is used for debugging to represent the gap + ;; (adjust-array (buffer-data buf) size :initial-element #\_ :fill-pointer t) + (let ((newbuf (make-array size :initial-element #\_;; :fill-pointer t + :element-type 'character))) + (replace newbuf (buffer-data buf)) + (setf (buffer-data buf) newbuf))) + +(defun gap-extend (buf size) + "Extend the gap by SIZE characters." + (let ((new-size (+ (length (buffer-data buf)) size)) + (old-end (gap-end buf)) + (old-size (buffer-size buf)) + (data (buffer-data buf))) + (setf data (grow-buffer-data buf new-size)) + (incf (buffer-gap-size buf) size) + (unless (= (buffer-gap-start buf) old-size) + (replace data data + :start1 (gap-end buf) + :start2 old-end)) + ;; for debugging, mark the gap + (fill-gap buf))) + +;; (defun buffer-char-before-point (buf p) +;; "The character at the point P in buffer BUF. P is in char space." +;; (declare (type buffer buf) +;; (type integer p)) +;; (let ((aref (buffer-char-to-aref buf p))) +;; (when (< aref (length (buffer-data buf))) +;; (aref (buffer-data buf) aref)))) + +(defgeneric buffer-insert (buffer object) + (:documentation "Insert OBJECT into BUFFER at the current point.")) + +(defmethod buffer-insert :after ((buf buffer) object) + "Any object insertion modifies the buffer." + (declare (ignore object)) + (setf (buffer-modified-p buf) t)) + +(defmethod buffer-insert ((buf buffer) (char character)) + "Insert a single character into buffer before point." + ;; Resize the gap if needed + (if (<= (buffer-gap-size buf) 1) + (gap-extend buf 100)) + ;; Move the gap to the point + (unless (= (pt buf) (buffer-gap-start buf)) + (gap-move-to buf (buffer-point-aref buf))) + (update-markers-ins buf (pt buf) 1) + ;; undo + (record-insert (pt buf) 1 buf) + ;; set the character + (setf (aref (buffer-data buf) (buffer-gap-start buf)) char) + ;; move the gap forward + (incf (buffer-gap-start buf)) + (decf (buffer-gap-size buf)) + ;; expand the buffer intervals + (offset-intervals buf (pt buf) 1)) + +(defmethod buffer-insert ((buf buffer) (string string)) + ;; resize + (when (<= (buffer-gap-size buf) (length string)) + (gap-extend buf (+ (length string) 100))) + ;; move the gap to the point + (unless (= (pt buf) (buffer-gap-start buf)) + (gap-move-to buf (buffer-point-aref buf))) + (update-markers-ins buf (pt buf) (length string)) + ;; undo + (record-insert (pt buf) (length string) buf) + ;; insert chars + (replace (buffer-data buf) string :start1 (buffer-gap-start buf)) + (incf (buffer-gap-start buf) (length string)) + (decf (buffer-gap-size buf) (length string)) + ;; expand the buffer intervals + (offset-intervals buf (pt buf) (length string))) + +(defmethod buffer-insert ((buf buffer) (string pstring)) + ;; insert string + (buffer-insert buf (pstring-data string)) + ;; insert properties + (graft-intervals-into-buffer (intervals string) + (pt buf) + (pstring-length string) + buf + t)) + +(defgeneric insert-move-point (buffer object) + (:documentation "Insert OBJECT into BUFFER at the current point. Move the point +forward by its length.")) + +(defmethod insert-move-point ((buffer buffer) (object character)) + (buffer-insert buffer object) + (incf (marker-position (buffer-point buffer)))) + +(defmethod insert-move-point ((buffer buffer) (object string)) + (buffer-insert buffer object) + (incf (marker-position (buffer-point buffer)) (length object))) + +(defmethod insert-move-point ((buffer buffer) (object pstring)) + (buffer-insert buffer object) + (incf (marker-position (buffer-point buffer)) (pstring-length object))) + +(defun buffer-delete (buf p length) + "Deletes chars from point to point + n. If N is negative, deletes backwards." + (cond ((< length 0) + (gap-move-to buf (buffer-char-to-aref buf p)) + (let* ((new (max 0 (+ (buffer-gap-start buf) length))) + (capped-size (- (buffer-gap-start buf) new))) + (update-markers-del buf new capped-size) + (record-delete new (make-buffer-string new (+ new capped-size) t buf)) + (adjust-intervals-for-deletion buf new capped-size) + (incf (buffer-gap-size buf) capped-size) + (setf (buffer-gap-start buf) new))) + ((> length 0) + (unless (>= p (zv buf)) + ;; can't delete forward if we're at the end of the buffer. + (gap-move-to buf (buffer-char-to-aref buf p)) + ;; Make sure the gap size doesn't grow beyond the buffer size. + (let ((capped-size (- (min (+ (gap-end buf) length) + (length (buffer-data buf))) + (gap-end buf)))) + (record-delete p (make-buffer-string p (+ p capped-size) t buf)) + (incf (buffer-gap-size buf) capped-size) + (update-markers-del buf p capped-size) + (adjust-intervals-for-deletion buf p capped-size))))) + (setf (buffer-modified-p buf) t) + ;; debuggning + (fill-gap buf)) + +(defun buffer-erase (&optional (buf (current-buffer))) + ;; update properties + (record-delete (begv buf) (make-buffer-string (begv buf) (zv buf) t buf) buf) + (adjust-intervals-for-deletion buf 0 (buffer-size buf)) + (update-markers-del buf 0 (buffer-size buf)) + ;; expand the gap to take up the whole buffer + (setf (buffer-gap-start buf) 0 + (buffer-gap-size buf) (length (buffer-data buf)) + (marker-position (buffer-point buf)) 0 + (buffer-modified-p buf) t) + ;; debugging + (fill-gap buf)) + +(defcommand erase-buffer ((&optional (buffer (current-buffer)))) +"Delete the entire contents of the current buffer. +Any narrowing restriction in effect (see `narrow-to-region') is removed, +so the buffer is truly empty after this." + (buffer-erase buffer)) diff --git a/intervals.lisp b/intervals.lisp index 7a261b1..b82b7c4 100644 --- a/intervals.lisp +++ b/intervals.lisp @@ -1,6 +1,6 @@ ;;; implentation of an interval tree -(in-package :lice) +(in-package "LICE") (defvar *text-property-default-nonsticky* nil "Alist of properties vs the corresponding non-stickinesses. @@ -33,36 +33,6 @@ character that does not have its own value for that property.") (,val (cadr ,csym))) ,@body)))) -;; interval node is a list: (key left right &rest plist) - -(defun print-interval (i s d) - (declare (ignore d)) - (format s "#S(interval ~s ~s ~s | ~s ~s)" - (interval-pt i) - (interval-length i) - (interval-plist i) - (interval-left i) - (interval-right i))) - -(defstruct (interval - (:print-function print-interval)) - (pt nil) - (length nil) - (left nil) - (right nil) - (parent nil :type (or null pstring buffer interval)) - (plist nil :type list)) - -;; MOVITZ's defstruct doesn't create copy-interval -#+movitz -(defun copy-interval (interval) - (make-interval :pt (interval-pt interval) - :length (interval-length interval) - :left (interval-left interval) - :right (interval-right interval) - :parent (interval-parent interval) - :plist (interval-plist interval))) - (defun interval-has-object (interval) (and (interval-parent interval) (not (typep (interval-parent interval) 'interval)))) @@ -128,48 +98,29 @@ We check for direct properties, for categories with property PROP, and for PROP appearing on the default-text-properties list." (lookup-char-property plist sym t)) -(defun split-interval-left (interval offset) - (let* ((new-length offset) - (new (make-interval :pt (interval-pt interval) - :length offset - :parent interval))) - (incf (interval-pt interval) offset) - (if (interval-left interval) - (progn - (setf (interval-left new) (interval-left interval) - (interval-parent (interval-left new)) new - (interval-left interval) new - (interval-length new) (+ new-length (interval-length (interval-left new)))) - (check-total-length new) - (balance-an-interval new)) - (progn - (setf (interval-left interval) new - (interval-length new) new-length) - (check-total-length new))) - (balance-possible-root-interval interval) - new)) +(defun total-length (root) + "TOTAL_LENGTH" + (if root + (interval-length root) + 0)) -(defun split-interval-right (interval offset) - (let* ((position (interval-pt interval)) - (new-length (- (interval-text-length interval) offset)) - (new (make-interval :pt (+ position offset) - :length 0 - :parent interval))) - (setf (interval-parent new) interval) - (if (interval-right interval) - (progn - (setf (interval-right new) (interval-right interval) - (interval-parent (interval-right interval)) new - (interval-right interval) new - (interval-length new) (+ new-length (interval-length (interval-right new)))) - (check-total-length new) - (balance-an-interval new)) - (progn - (setf (interval-right interval) new - (interval-length new) new-length) - (check-total-length new))) - (balance-possible-root-interval interval) - new)) +(defun left-total-length (root) + (if (interval-left root) + (interval-length (interval-left root)) + 0)) + +(defun right-total-length (root) + (if (interval-right root) + (interval-length (interval-right root)) + 0)) + +(defun interval-text-length (root) + "The size of text represented by this interval alone. LENGTH." + (if root + (- (total-length root) + (total-length (interval-right root)) + (total-length (interval-left root))) + 0)) (defun right-child-p (root) (eq root (interval-right (interval-parent root)))) @@ -182,17 +133,41 @@ and for PROP appearing on the default-text-properties list." climbed past the root interval." (not (typep (interval-parent interval) 'interval))) -(defun rotate-right (interval) -"Assuming that a left child exists, perform the following operation: +(defun root-interval-p (i) + "Return true if i is the root interval node." + (or (null (interval-parent i)) + (not (typep (interval-parent i) 'interval)))) - A B - / \ / \ - B => A - / \ / \ - c c +(defun root-interval (interval) + "Return the root of interval." + (do ((i interval (interval-parent i))) + ((root-interval-p i) i))) + +(defun leaf-interval-p (i) + "Return T if this interval has no children." + (and (null (interval-left i)) + (null (interval-right i)))) + +(defun only-interval-p (i) + "Return T if this interval is the only interval in the interval tree." + (and (root-interval-p i) + (leaf-interval-p i))) + +(defun default-interval-p (i) + (or (null i) + (null (interval-plist i)))) + +(defun rotate-left (interval) +"Assuming that a right child exists, perform the following operation: + + A B + / \ / \ + B => A + / \ / \ + c c " (let ((old-total (interval-length interval)) - (b (interval-left interval)) + (b (interval-right interval)) i) ;; Change interval's parent to point b. (unless (root-interval-p interval) @@ -201,33 +176,33 @@ climbed past the root interval." (setf (interval-right (interval-parent interval)) b))) (setf (interval-parent b) (interval-parent interval)) ;; Make b the parent of a - (setf i (interval-right b) - (interval-right b) interval + (setf i (interval-left b) + (interval-left b) interval (interval-parent interval) b) ;; make a point to c - (setf (interval-left interval) i) + (setf (interval-right interval) i) (when i (setf (interval-parent i) interval)) ;; A's total length is decreased by the length of B and its left child. (decf (interval-length interval) (- (interval-length b) - (left-total-length interval))) + (right-total-length interval))) (check-total-length interval) ;; B must have the same total length of A. (setf (interval-length b) old-total) (check-total-length b) b)) -(defun rotate-left (interval) -"Assuming that a right child exists, perform the following operation: +(defun rotate-right (interval) +"Assuming that a left child exists, perform the following operation: - A B - / \ / \ - B => A - / \ / \ - c c + A B + / \ / \ + B => A + / \ / \ + c c " (let ((old-total (interval-length interval)) - (b (interval-right interval)) + (b (interval-left interval)) i) ;; Change interval's parent to point b. (unless (root-interval-p interval) @@ -236,45 +211,21 @@ climbed past the root interval." (setf (interval-right (interval-parent interval)) b))) (setf (interval-parent b) (interval-parent interval)) ;; Make b the parent of a - (setf i (interval-left b) - (interval-left b) interval + (setf i (interval-right b) + (interval-right b) interval (interval-parent interval) b) ;; make a point to c - (setf (interval-right interval) i) + (setf (interval-left interval) i) (when i (setf (interval-parent i) interval)) ;; A's total length is decreased by the length of B and its left child. (decf (interval-length interval) (- (interval-length b) - (right-total-length interval))) + (left-total-length interval))) (check-total-length interval) ;; B must have the same total length of A. (setf (interval-length b) old-total) (check-total-length b) b)) - -(defun total-length (root) - "TOTAL_LENGTH" - (if root - (interval-length root) - 0)) - -(defun left-total-length (root) - (if (interval-left root) - (interval-length (interval-left root)) - 0)) - -(defun right-total-length (root) - (if (interval-right root) - (interval-length (interval-right root)) - 0)) - -(defun interval-text-length (root) - "The size of text represented by this interval alone. LENGTH." - (if root - (- (total-length root) - (total-length (interval-right root)) - (total-length (interval-left root))) - 0)) (defun balance-an-interval (i) (let (old-diff @@ -302,6 +253,18 @@ climbed past the root interval." (balance-an-interval (interval-left i))) (t (return-from balance-an-interval i)))))) +(defun balance-intervals (tree) + "Balance the interval tree TREE. Balancing is by weight: the amount +of text." + (labels ((balance (tree) + (when (interval-left tree) + (balance (interval-left tree))) + (when (interval-right tree) + (balance (interval-right tree))) + (balance-an-interval tree))) + (when tree + (balance tree)))) + (defun balance-possible-root-interval (interval) (let ((has-parent nil) parent) @@ -315,17 +278,48 @@ climbed past the root interval." (setf (intervals parent) interval)) interval)) -(defun balance-intervals (tree) - "Balance the interval tree TREE. Balancing is by weight: the amount -of text." - (labels ((balance (tree) - (when (interval-left tree) - (balance (interval-left tree))) - (when (interval-right tree) - (balance (interval-right tree))) - (balance-an-interval tree))) - (when tree - (balance tree)))) +(defun split-interval-left (interval offset) + (let* ((new-length offset) + (new (make-interval :pt (interval-pt interval) + :length offset + :parent interval))) + (incf (interval-pt interval) offset) + (if (interval-left interval) + (progn + (setf (interval-left new) (interval-left interval) + (interval-parent (interval-left new)) new + (interval-left interval) new + (interval-length new) (+ new-length (interval-length (interval-left new)))) + (check-total-length new) + (balance-an-interval new)) + (progn + (setf (interval-left interval) new + (interval-length new) new-length) + (check-total-length new))) + (balance-possible-root-interval interval) + new)) + +(defun split-interval-right (interval offset) + (let* ((position (interval-pt interval)) + (new-length (- (interval-text-length interval) offset)) + (new (make-interval :pt (+ position offset) + :length 0 + :parent interval))) + (setf (interval-parent new) interval) + (if (interval-right interval) + (progn + (setf (interval-right new) (interval-right interval) + (interval-parent (interval-right interval)) new + (interval-right interval) new + (interval-length new) (+ new-length (interval-length (interval-right new)))) + (check-total-length new) + (balance-an-interval new)) + (progn + (setf (interval-right interval) new + (interval-length new) new-length) + (check-total-length new))) + (balance-possible-root-interval interval) + new)) (defun find-interval (tree position) (let ((relative-position position)) @@ -385,6 +379,47 @@ of text." (return-from previous-interval i)) do (setf i (interval-parent i)))))) +(defun delete-node (i) + ;; Trivial cases + (when (null (interval-left i)) + (return-from delete-node (interval-right i))) + (when (null (interval-right i)) + (return-from delete-node (interval-left i))) + ;; Meat + (let ((migrate (interval-left i)) + (this (interval-right i)) + (migrate-amt (interval-length (interval-left i)))) + (while (interval-left this) + (setf this (interval-left this)) + (incf (interval-length this) migrate-amt)) + (check-total-length this) + (setf (interval-left this) migrate) + (setf (interval-parent migrate) this) + (interval-right i))) + +(defun delete-interval (i) + (let ((amt (interval-text-length i)) + parent) + (and (> amt 0) + (error "only used on zero length intervals.")) + (when (root-interval-p i) + (let ((owner (interval-parent i))) + (setf parent (delete-node i)) + (when (interval-parent parent) + (setf (interval-parent parent) owner)) + (setf (intervals owner) parent) + (return-from delete-interval))) + (setf parent (interval-parent i)) + (if (left-child-p i) + (progn + (setf (interval-left parent) (delete-node i)) + (when (interval-left parent) + (setf (interval-parent (interval-left parent)) parent))) + (progn + (setf (interval-right parent) (delete-node i)) + (when (interval-right parent) + (setf (interval-parent (interval-right parent)) parent)))))) + (defun merge-interval-right (i) (let ((absorb (interval-text-length i)) successor) @@ -440,8 +475,155 @@ of text." ) (error "merge-interval-left: gak"))) +(defun copy-properties (source target) + (when (and (default-interval-p source) + (default-interval-p target)) + (return-from copy-properties)) + (setf (interval-plist target) (copy-list (interval-plist source)))) + +(defun merge-properties (source target) + "/* Merge the properties of interval SOURCE into the properties of +interval TARGET. That is to say, each property in SOURCE is added to +TARGET if TARGET has no such property as yet. */" + (unless (and (default-interval-p source) + (default-interval-p target)) + (doplist (sym val (interval-plist source)) + (let ((found (getf (interval-plist target) sym))) + (unless found + (setf (getf (interval-plist target) sym) val)))))) -;; adjust_intervals_for_insertion (tree, position, length) +(defun merge-properties-sticky (pleft pright) + "Any property might be front-sticky on the left, rear-sticky on the left, +front-sticky on the right, or rear-sticky on the right; the 16 combinations +can be arranged in a matrix with rows denoting the left conditions and +columns denoting the right conditions: + _ __ _ +_ FR FR FR FR +FR__ 0 1 2 3 + _FR 4 5 6 7 +FR 8 9 A B + FR C D E F + +left-props = '(front-sticky (p8 p9 pa pb pc pd pe pf) + rear-nonsticky (p4 p5 p6 p7 p8 p9 pa pb) + p0 L p1 L p2 L p3 L p4 L p5 L p6 L p7 L + p8 L p9 L pa L pb L pc L pd L pe L pf L) +right-props = '(front-sticky (p2 p3 p6 p7 pa pb pe pf) + rear-nonsticky (p1 p2 p5 p6 p9 pa pd pe) + p0 R p1 R p2 R p3 R p4 R p5 R p6 R p7 R + p8 R p9 R pa R pb R pc R pd R pe R pf R) + +We inherit from whoever has a sticky side facing us. If both sides +do (cases 2, 3, E, and F), then we inherit from whichever side has a +non-nil value for the current property. If both sides do, then we take +from the left. + +When we inherit a property, we get its stickiness as well as its value. +So, when we merge the above two lists, we expect to get this: + +result = '(front-sticky (p6 p7 pa pb pc pd pe pf) + rear-nonsticky (p6 pa) + p0 L p1 L p2 L p3 L p6 R p7 R + pa R pb R pc L pd L pe L pf L) + +The optimizable special cases are: + left rear-nonsticky = nil, right front-sticky = nil (inherit left) + left rear-nonsticky = t, right front-sticky = t (inherit right) + left rear-nonsticky = t, right front-sticky = nil (inherit none)" + (labels ((tmem (sym set) + ;; Test for membership, allowing for t (actually any + ;; non-cons) to mean the universal set." + (if (consp set) + (find sym set) + set))) + (let (props + front + rear + (lfront (getf pleft 'front-sticky)) + (lrear (getf pleft 'rear-nonsticky)) + (rfront (getf pright 'front-sticky)) + (rrear (getf pright 'rear-nonsticky)) + cat use-left use-right) + (doplist (sym rval pright) + (unless (or (eq sym 'rear-nonsticky) + (eq sym 'front-sticky)) + ;; Indicate whether the property is explicitly + ;; defined on the left. (We know it is defined + ;; explicitly on the right because otherwise we don't + ;; get here.) + (let* ((lval (getf pleft sym)) + ;; Even if lrear or rfront say nothing about the + ;; stickiness of SYM, + ;; Vtext_property_default_nonsticky may give + ;; default stickiness to SYM. + (tmp (assoc sym *text-property-default-nonsticky*))) + (setf use-left (and lval + (not (or (tmem sym lrear) + (and (consp tmp) + (cdr tmp))))) + use-right (or (tmem sym lrear) + (and (consp tmp) + (null (cdr tmp))))) + (when (and use-left + use-right) + (cond ((null lval) + (setf use-left nil)) + ((null rval) + (setf use-right nil)))) + (cond (use-left + ;; We build props as (value sym ...) rather than (sym value ...) + ;; because we plan to nreverse it when we're done. + (setf (getf props sym) lval) + (when (tmem sym lfront) + (push sym front)) + (when (tmem sym lrear) + (push sym rear))) + (use-right + (setf (getf props sym) rval) + (when (tmem sym rfront) + (push sym front)) + (when (tmem sym rrear) + (push sym rear))))))) + ;; Now go through each element of PLEFT. + (doplist (sym lval pleft) + (unless (or (eq sym 'rear-nonsticky) + (eq sym 'front-sticky)) + ;; If sym is in PRIGHT, we've already considered it. + (let* ((present (getf pright sym)) + ;; Even if lrear or rfront say nothing about the + ;; stickiness of SYM, + ;; Vtext_property_default_nonsticky may give + ;; default stickiness to SYM. + (tmp (assoc sym *text-property-default-nonsticky*))) + ;; XXX: if sym is set in pright to nil, its the same + ;; as sym not being in the list. + (unless present + ;; Since rval is known to be nil in this loop, the test simplifies. + (cond ((not (or (tmem sym lrear) + (and (consp tmp) + (cdr tmp)))) + (setf (getf props sym) lval) + (when (tmem sym lfront) + (push sym front))) + ((or (tmem sym rfront) + (and (consp tmp) + (null (cdr tmp)))) + ;; The value is nil, but we still inherit the stickiness + ;; from the right. + (setf (getf props sym) lval) + (when (tmem sym rrear) + (push sym rear)))))))) + (when rear + (setf (getf props 'rear-nonsticky) (nreverse rear))) + (setf cat (textget props 'category)) + ;; If we have inherited a front-stick category property that is t, + ;; we don't need to set up a detailed one. + (when (and front + (not (and cat + (symbolp cat) + (eq (get cat 'front-sticky) t)))) + (setf (getf props 'front-sticky) (nreverse front))) + props))) (defun adjust-intervals-for-insertion (tree position length) "Effect an adjustment corresponding to the addition of LENGTH characters @@ -647,6 +829,68 @@ buffer position, i.e. origin 1)." 0 (buffer-min (interval-parent source)))) +(defun reproduce-tree (source parent) + (let ((tree (copy-interval source))) + (setf (interval-plist tree) (copy-list (interval-plist source)) + (interval-parent tree) parent) + (when (interval-left source) + (setf (interval-left tree) (reproduce-tree (interval-left source) tree))) + (when (interval-right source) + (setf (interval-right tree) (reproduce-tree (interval-right source) tree))) + tree)) + +(defun set-properties (properties interval object) + (when (typep object 'buffer) + ;; record undo info + ) + (setf (interval-plist interval) (copy-tree properties))) + +(defun set-text-properties-1 (start end properties buffer i) + (let ((len (- end start)) + (prev-changed nil) + unchanged) + (when (zerop len) + (return-from set-text-properties-1)) + (when (minusp len) + (incf start len) + (setf len (abs len))) + (when (null i) + (setf i (find-interval (intervals buffer) start))) + (when (/= (interval-pt i) start) + (setf unchanged i + i (split-interval-right unchanged (- start (interval-pt unchanged)))) + (when (> (interval-text-length i) len) + (copy-properties unchanged i) + (setf i (split-interval-left i len)) + (set-properties properties i buffer) + (return-from set-text-properties-1)) + (set-properties properties i buffer) + (when (= (interval-text-length i) len) + (return-from set-text-properties-1)) + (setf prev-changed i) + (decf len (interval-text-length i)) + (setf i (next-interval i))) + (while (> len 0) + (when (null i) + (error "borked.")) + (when (>= (interval-text-length i) len) + (when (> (interval-text-length i) len) + (setf i (split-interval-left i len))) + (set-properties properties i buffer) + (when prev-changed + (merge-interval-left i)) + (return-from set-text-properties-1)) + (decf len (interval-text-length i)) + ;; We have to call set_properties even if we are going + ;; to merge the intervals, so as to make the undo + ;; records and cause redisplay to happen. + (set-properties properties i buffer) + (if (null prev-changed) + (setf prev-changed i) + (setf prev-changed (merge-interval-left i) + i prev-changed)) + (setf i (next-interval i))))) + (defun graft-intervals-into-buffer (source position length buffer inherit) "Insert the intervals of SOURCE into BUFFER at POSITION. LENGTH is the length of the text in SOURCE. @@ -760,226 +1004,6 @@ text..." (when (intervals buffer) (setf (intervals buffer) (balance-an-interval (intervals buffer)))))) -(defun root-interval-p (i) - "Return true if i is the root interval node." - (or (null (interval-parent i)) - (not (typep (interval-parent i) 'interval)))) - -(defun root-interval (interval) - "Return the root of interval." - (do ((i interval (interval-parent i))) - ((root-interval-p i) i))) - -(defun leaf-interval-p (i) - "Return T if this interval has no children." - (and (null (interval-left i)) - (null (interval-right i)))) - -(defun only-interval-p (i) - "Return T if this interval is the only interval in the interval tree." - (and (root-interval-p i) - (leaf-interval-p i))) - - -(defun delete-node (i) - ;; Trivial cases - (when (null (interval-left i)) - (return-from delete-node (interval-right i))) - (when (null (interval-right i)) - (return-from delete-node (interval-left i))) - ;; Meat - (let ((migrate (interval-left i)) - (this (interval-right i)) - (migrate-amt (interval-length (interval-left i)))) - (while (interval-left this) - (setf this (interval-left this)) - (incf (interval-length this) migrate-amt)) - (check-total-length this) - (setf (interval-left this) migrate) - (setf (interval-parent migrate) this) - (interval-right i))) - -(defun delete-interval (i) - (let ((amt (interval-text-length i)) - parent) - (and (> amt 0) - (error "only used on zero length intervals.")) - (when (root-interval-p i) - (let ((owner (interval-parent i))) - (setf parent (delete-node i)) - (when (interval-parent parent) - (setf (interval-parent parent) owner)) - (setf (intervals owner) parent) - (return-from delete-interval))) - (setf parent (interval-parent i)) - (if (left-child-p i) - (progn - (setf (interval-left parent) (delete-node i)) - (when (interval-left parent) - (setf (interval-parent (interval-left parent)) parent))) - (progn - (setf (interval-right parent) (delete-node i)) - (when (interval-right parent) - (setf (interval-parent (interval-right parent)) parent)))))) - -(defun default-interval-p (i) - (or (null i) - (null (interval-plist i)))) - -(defun reproduce-tree (source parent) - (let ((tree (copy-interval source))) - (setf (interval-plist tree) (copy-list (interval-plist source)) - (interval-parent tree) parent) - (when (interval-left source) - (setf (interval-left tree) (reproduce-tree (interval-left source) tree))) - (when (interval-right source) - (setf (interval-right tree) (reproduce-tree (interval-right source) tree))) - tree)) - -(defun merge-properties (source target) - "/* Merge the properties of interval SOURCE into the properties of -interval TARGET. That is to say, each property in SOURCE is added to -TARGET if TARGET has no such property as yet. */" - (unless (and (default-interval-p source) - (default-interval-p target)) - (doplist (sym val (interval-plist source)) - (let ((found (getf (interval-plist target) sym))) - (unless found - (setf (getf (interval-plist target) sym) val)))))) - -(defun merge-properties-sticky (pleft pright) - "Any property might be front-sticky on the left, rear-sticky on the left, -front-sticky on the right, or rear-sticky on the right; the 16 combinations -can be arranged in a matrix with rows denoting the left conditions and -columns denoting the right conditions: - _ __ _ -_ FR FR FR FR -FR__ 0 1 2 3 - _FR 4 5 6 7 -FR 8 9 A B - FR C D E F - -left-props = '(front-sticky (p8 p9 pa pb pc pd pe pf) - rear-nonsticky (p4 p5 p6 p7 p8 p9 pa pb) - p0 L p1 L p2 L p3 L p4 L p5 L p6 L p7 L - p8 L p9 L pa L pb L pc L pd L pe L pf L) -right-props = '(front-sticky (p2 p3 p6 p7 pa pb pe pf) - rear-nonsticky (p1 p2 p5 p6 p9 pa pd pe) - p0 R p1 R p2 R p3 R p4 R p5 R p6 R p7 R - p8 R p9 R pa R pb R pc R pd R pe R pf R) - -We inherit from whoever has a sticky side facing us. If both sides -do (cases 2, 3, E, and F), then we inherit from whichever side has a -non-nil value for the current property. If both sides do, then we take -from the left. - -When we inherit a property, we get its stickiness as well as its value. -So, when we merge the above two lists, we expect to get this: - -result = '(front-sticky (p6 p7 pa pb pc pd pe pf) - rear-nonsticky (p6 pa) - p0 L p1 L p2 L p3 L p6 R p7 R - pa R pb R pc L pd L pe L pf L) - -The optimizable special cases are: - left rear-nonsticky = nil, right front-sticky = nil (inherit left) - left rear-nonsticky = t, right front-sticky = t (inherit right) - left rear-nonsticky = t, right front-sticky = nil (inherit none)" - (labels ((tmem (sym set) - ;; Test for membership, allowing for t (actually any - ;; non-cons) to mean the universal set." - (if (consp set) - (find sym set) - set))) - (let (props - front - rear - (lfront (getf pleft 'front-sticky)) - (lrear (getf pleft 'rear-nonsticky)) - (rfront (getf pright 'front-sticky)) - (rrear (getf pright 'rear-nonsticky)) - cat use-left use-right) - (doplist (sym rval pright) - (unless (or (eq sym 'rear-nonsticky) - (eq sym 'front-sticky)) - ;; Indicate whether the property is explicitly - ;; defined on the left. (We know it is defined - ;; explicitly on the right because otherwise we don't - ;; get here.) - (let* ((lval (getf pleft sym)) - ;; Even if lrear or rfront say nothing about the - ;; stickiness of SYM, - ;; Vtext_property_default_nonsticky may give - ;; default stickiness to SYM. - (tmp (assoc sym *text-property-default-nonsticky*))) - (setf use-left (and lval - (not (or (tmem sym lrear) - (and (consp tmp) - (cdr tmp))))) - use-right (or (tmem sym lrear) - (and (consp tmp) - (null (cdr tmp))))) - (when (and use-left - use-right) - (cond ((null lval) - (setf use-left nil)) - ((null rval) - (setf use-right nil)))) - (cond (use-left - ;; We build props as (value sym ...) rather than (sym value ...) - ;; because we plan to nreverse it when we're done. - (setf (getf props sym) lval) - (when (tmem sym lfront) - (push sym front)) - (when (tmem sym lrear) - (push sym rear))) - (use-right - (setf (getf props sym) rval) - (when (tmem sym rfront) - (push sym front)) - (when (tmem sym rrear) - (push sym rear))))))) - ;; Now go through each element of PLEFT. - (doplist (sym lval pleft) - (unless (or (eq sym 'rear-nonsticky) - (eq sym 'front-sticky)) - ;; If sym is in PRIGHT, we've already considered it. - (let* ((present (getf pright sym)) - ;; Even if lrear or rfront say nothing about the - ;; stickiness of SYM, - ;; Vtext_property_default_nonsticky may give - ;; default stickiness to SYM. - (tmp (assoc sym *text-property-default-nonsticky*))) - ;; XXX: if sym is set in pright to nil, its the same - ;; as sym not being in the list. - (unless present - ;; Since rval is known to be nil in this loop, the test simplifies. - (cond ((not (or (tmem sym lrear) - (and (consp tmp) - (cdr tmp)))) - (setf (getf props sym) lval) - (when (tmem sym lfront) - (push sym front))) - ((or (tmem sym rfront) - (and (consp tmp) - (null (cdr tmp)))) - ;; The value is nil, but we still inherit the stickiness - ;; from the right. - (setf (getf props sym) lval) - (when (tmem sym rrear) - (push sym rear)))))))) - (when rear - (setf (getf props 'rear-nonsticky) (nreverse rear))) - (setf cat (textget props 'category)) - ;; If we have inherited a front-stick category property that is t, - ;; we don't need to set up a detailed one. - (when (and front - (not (and cat - (symbolp cat) - (eq (get cat 'front-sticky) t)))) - (setf (getf props 'front-sticky) (nreverse front))) - props))) - (defun offset-intervals (buffer start length) "Make the adjustments necessary to the interval tree of BUFFER to represent an addition or deletion of LENGTH characters starting diff --git a/input.lisp b/keyboard.lisp similarity index 83% rename from input.lisp rename to keyboard.lisp index e18cdc4..607fbaa 100644 --- a/input.lisp +++ b/keyboard.lisp @@ -1,20 +1,11 @@ ;;; Handle input and key command dispatching -(in-package :lice) +(in-package "LICE") (define-condition quit (lice-condition) () (:documentation "A condition raised when the user aborted the operation (by pressing C-g, for instance).")) -(defvar *last-point-position-buffer* nil - "The buffer that was current when the last command was started.") - -(defvar *last-point-position-window* nil - "The window that was selected when the last command was started.") - -(defvar *last-point-position* nil - "The value of point when the last command was started.") - (defvar *last-command* nil "The last command executed.") @@ -25,17 +16,6 @@ when the command finishes. The command can change this value if it wants to change what *last-command* will be set to. Used in the `yank' and `yank-pop' commands.") -(defvar *prefix-arg* nil - "The value of the prefix argument for the next editing command. -It may be a number, or the symbol `-' for just a minus sign as arg, -or a list whose car is a number for just one or more C-u's -or nil if no argument has been specified. - -You cannot examine this variable to find the argument for this command -since it has been set to nil by the time you can look. -Instead, you should use the variable `current-prefix-arg', although -normally commands can get this prefix argument with (interactive \"P\").") - (defvar *current-prefix-arg* nil "The value of the prefix argument for this editing command. It may be a number, or the symbol `-' for just a minus sign as arg, @@ -87,9 +67,6 @@ The value is a list of KEYs." ;;; events -(defvar *current-event* nil - "The current event being processed.") - (defvar *unread-command-events* nil "List of events to be read as the command input. These events are processed first, before actual keyboard input.") @@ -99,6 +76,31 @@ These events are processed first, before actual keyboard input.") events that invoked the current command." (key-char (car *this-command-keys*))) +;; This is really TTY specific +(defun next-event () + (let* ((*current-event* (if *unread-command-events* + (pop *unread-command-events*) + (wait-for-event))) + (def (if *current-kmap* + (lookup-key *current-kmap* *current-event* t) + ;; no current kmap? + (or + (when *overriding-terminal-local-map* + (lookup-key-internal *overriding-terminal-local-map* *current-event* t *current-keymap-theme* t)) + (when *overriding-local-map* + (lookup-key-internal *overriding-local-map* *current-event* t *current-keymap-theme* t)) + (when (current-local-map) + (lookup-key-internal (current-local-map) *current-event* t *current-keymap-theme* t)) + ;;(lookup-key-internal (major-mode-map (major-mode)) *current-event* t *current-keymap-theme* t) + ;; TODO: minor mode maps + ;; check the global map + (lookup-key-internal *global-map* *current-event* t *current-keymap-theme* t))))) + (dformat +debug-v+ "~a ~s ~a~%" + def #|(key-hashid *current-event*)|# *current-event* (key-char *current-event*)) + (if def + (handle-key-binding def *current-event*) + (message "~{~a ~}is undefined" (mapcar 'print-key (cons *current-event* (this-command-keys))))))) + (defgeneric handle-key-binding (binding key-seq)) (defmethod handle-key-binding ((binding keymap) key-seq) @@ -149,36 +151,12 @@ events that invoked the current command." ;; check again. (sleep 0.01)))))) -;; This is really TTY specific -(defun next-event () - (let* ((*current-event* (if *unread-command-events* - (pop *unread-command-events*) - (wait-for-event))) - (def (if *current-kmap* - (lookup-key *current-kmap* *current-event* t) - ;; no current kmap? - (or - (when *overriding-terminal-local-map* - (lookup-key-internal *overriding-terminal-local-map* *current-event* t *current-keymap-theme* t)) - (when *overriding-local-map* - (lookup-key-internal *overriding-local-map* *current-event* t *current-keymap-theme* t)) - (when (current-local-map) - (lookup-key-internal (current-local-map) *current-event* t *current-keymap-theme* t)) - (lookup-key-internal (major-mode-map (major-mode)) *current-event* t *current-keymap-theme* t) - ;; TODO: minor mode maps - ;; check the global map - (lookup-key-internal *global-map* *current-event* t *current-keymap-theme* t))))) - (dformat +debug-v+ "~a ~s ~a~%" - def #|(key-hashid *current-event*)|# *current-event* (key-char *current-event*)) - (if def - (handle-key-binding def *current-event*) - (message "~{~a ~}is undefined" (mapcar 'print-key (cons *current-event* (this-command-keys))))))) (defun top-level-next-event () ;; Bind this locally so its value is restored after the ;; command is dispatched. Otherwise, calls to set-buffer ;; would stick. - (setf *current-buffer* (window-buffer (frame-current-window (selected-frame)))) + (setf *current-buffer* (window-buffer (frame-selected-window (selected-frame)))) (next-event)) (provide :lice-0.1/input) diff --git a/keymap.lisp b/keymap.lisp index 56645be..f4a9690 100644 --- a/keymap.lisp +++ b/keymap.lisp @@ -28,6 +28,57 @@ (defmethod print-object ((obj key) stream) (print-unreadable-object (obj stream :type t :identity t) (format stream "~s" (print-key obj)))) + +(define-condition kbd-parse (lice-condition) + () (:documentation "Raised when a kbd string failed to parse.")) + +(defun parse-mods (mods end) + "MODS is a sequence of #\- pairs. Return a list suitable +for passing as the last argument to (apply #'make-key ...)" + (unless (evenp end) + (signal 'kbd-parse)) + (apply #'nconc (loop for i from 0 below end by 2 + if (char/= (char mods (1+ i)) #\-) + do (signal 'kbd-parse) + collect (case (char mods i) + (#\M (list :meta t)) + (#\A (list :alt t)) + (#\C (list :control t)) + (#\H (list :hyper t)) + (#\s (list :super t)) + (#\S (list :shift t)) + (t (signal 'kbd-parse)))))) + +(defun parse-char-name (string) + "Return the character whose name is STRING." + (or (cond + ((string= string "RET") #\Newline) + ((string= string "TAB") #\Tab)) + (name-char string) + (and (= (length string) 1) + (char string 0)))) + +(defun parse-key (string) + "Parse STRING and return a key structure." + ;; FIXME: we want to return NIL when we get a kbd-parse error + ;;(ignore-errors + (let* ((p (when (> (length string) 2) + (position #\- string :from-end t :end (- (length string) 1)))) + (mods (parse-mods string (if p (1+ p) 0))) + (ch (parse-char-name (subseq string (if p (1+ p) 0))))) + (and ch + (apply #'make-key :char ch mods)))) + +(defun parse-key-seq (keys) + "KEYS is a key sequence. Parse it and return the list of keys." + (mapcar 'parse-key (split-string keys))) + +(defun kbd (keys) + "Convert KEYS to the internal Emacs key representation. +KEYS should be a string constant in the format used for +saving keyboard macros ***(see `insert-kbd-macro')." + ;; XXX: define-key needs to be fixed to handle a list of keys + (first (parse-key-seq keys))) ;; ;; XXX: This is hacky. Convert the class into a sequence. Maybe we should ;; ;; use defstruct then? @@ -62,6 +113,9 @@ buffer's local map, the minor mode keymaps, and char property keymaps.") (prompt :initform nil :initarg :prompt :accessor keymap-prompt) (themes :initform (make-hash-table) :accessor keymap-themes))) +(defun keymapp (object) + (typep object 'keymap)) + (defun make-sparse-keymap (&optional prompt) "Construct and return a new sparse keymap. The optional arg STRING supplies a menu name for the keymap @@ -87,11 +141,11 @@ in case you use it as a menu with `x-popup-menu'." ;; if the binding is another keymap, then lookup the rest of the key sequence (cond ((and (keymapp cmd) (not norecurse)) - (lookup-key cmd (cdr key) accept-default theme)) + (lookup-key-internal cmd (cdr key) accept-default theme norecurse)) (t cmd)) ;; check parent for binding (when (keymap-parent keymap) - (lookup-key (keymap-parent keymap) key nil theme)) + (lookup-key-internal (keymap-parent keymap) key nil theme norecurse)) (when accept-default (and map (gethash t map)))))) @@ -107,9 +161,6 @@ recognize the default bindings, just as `read-key-sequence' does." (check-type keymap keymap) (lookup-key-internal keymap key accept-default theme nil)) -(defun keymapp (object) - (typep object 'keymap)) - (depricate set-keymap-parent (setf keymap-parent)) (defun set-keymap-parent (keymap parent) "Modify keymap to set its parent map to parent. @@ -118,7 +169,7 @@ Return parent. parent should be nil or another keymap." (defun make-keymap (&optional string) (declare (ignore string)) - (error 'unimplemented)) + (error "unimplemented")) (defun map-keymap (function keymap &optional (theme :lice)) "Call FUNCTION once for each event binding in KEYMAP. @@ -267,26 +318,26 @@ more." (defun copy-keymap (keymap) (declare (ignore keymap)) - (error 'unimplemented)) + (error "unimplemented")) (defun command-remapping () - (error 'unimplemented)) + (error "unimplemented")) (defun key-binding (key &optional accept-default no-remap) (declare (ignore key accept-default no-remap)) - (error 'unimplemented)) + (error "unimplemented")) (defun local-key-binding () - (error 'unimplemented)) + (error "unimplemented")) (defun global-key-binding () - (error 'unimplemented)) + (error "unimplemented")) (defun minor-mode-key-binding () - (error 'unimplemented)) + (error "unimplemented")) (defun define-prefix-command () - (error 'unimplemented)) + (error "unimplemented")) (defun use-global-map (keymap) (check-type keymap keymap) @@ -294,12 +345,9 @@ more." (defun use-local-map (keymap) "Select KEYMAP as the local keymap. -If KEYMAP is nil, that means no local keymap. - -LICE: a buffer's local map is really the major mode map. Except -it might not be in the future." +If KEYMAP is nil, that means no local keymap." (check-type keymap keymap) - (error 'unimplemented)) + (setf (buffer-local-map (current-buffer)) keymap)) (defun current-local-map () "Return current buffer's local keymap, or nil if it has none. @@ -313,32 +361,32 @@ not be in the future." *current-global-map*) (defun current-minor-mode-maps () - (error 'unimplemented)) + (error "unimplemented")) (defun current-active-maps () - (error 'unimplemented)) + (error "unimplemented")) (defun accessible-keymaps () - (error 'unimplemented)) + (error "unimplemented")) (defun key-description () - (error 'unimplemented)) + (error "unimplemented")) (defun describe-vector () - (error 'unimplemented)) + (error "unimplemented")) (defun single-key-description () - (error 'unimplemented)) + (error "unimplemented")) (defun text-char-description () - (error 'unimplemented)) + (error "unimplemented")) (defun where-is-internal () - (error 'unimplemented)) + (error "unimplemented")) (defun describe-buffer-bindings () - (error 'unimplemented)) + (error "unimplemented")) (defun apropos-internal () - (error 'unimplemented)) + (error "unimplemented")) diff --git a/lice.asd b/lice.asd dissimilarity index 85% index 5adcc49..1e18703 100644 --- a/lice.asd +++ b/lice.asd @@ -1,37 +1,52 @@ -;; -*- lisp -*- - -#+sbcl (require 'sb-posix) - -(defsystem :lice - :depends-on (cl-ncurses cl-ppcre) - :components ((:file "wrappers") - (:file "global") - (:file "custom") - (:file "keymap") - (:file "input") - (:file "subr") - (:file "major-mode") - (:file "buffer") - (:file "files") - (:file "intervals") - (:file "textprop") - (:file "editfns") - (:file "window") - (:file "frame") - (:file "tty-render") - (:file "syntax") - (:file "debugger") - (:file "recursive-edit") - (:file "wm") - (:file "minibuffer") - (:file "simple") - (:file "undo") - (:file "indent") - (:file "lisp-mode") - (:file "search") - (:file "help") - (:file "debug") - (:file "subprocesses") - (:file "lisp-indent") - (:file "main" - :depends-on ("wrappers" "global" "custom" "input" "keymap" "subr" "major-mode" "buffer" "files" "intervals" "textprop" "editfns" "window" "frame" "tty-render" "syntax" "debugger" "recursive-edit" "wm" "minibuffer" "simple" "undo" "indent" "lisp-mode" "search" "help" "debug" "subprocesses" "lisp-indent")))) +;; -*- lisp -*- + +#+sbcl (require 'sb-posix) + +(load "package.lisp") + +(defsystem :lice + :depends-on (cl-ncurses cl-ppcre) + :components ((:file "wrappers") + (:file "global") + (:file "custom") + (:file "commands") + (:file "data-types") + (:file "keymap" :depends-on ("global")) + (:file "casefiddle") + (:file "subprocesses" :depends-on ("wrappers" "commands")) + (:file "buffer-local" :depends-on ("data-types")) + (:file "buffer" :depends-on ("data-types" "buffer-local" "commands" "wrappers" "global")) + (:file "intervals" :depends-on ("data-types")) + (:file "textprop" :depends-on ("intervals" "global")) + (:file "search" :depends-on ("buffer")) + (:file "frame" :depends-on ("data-types")) + (:file "window" :depends-on ("buffer" "search" "commands" "frame" "data-types")) + (:file "render" :depends-on ("frame" "window")) + (:file "wm" :depends-on ("data-types" "window" "frame")) + + ;; from this point on there are warnings because of two-way dependencies + (:file "insdel" :depends-on ("intervals" #|"undo"|# "buffer")) + (:file "cmds" :depends-on ("keymap" "insdel")) + (:file "editfns" :depends-on ("buffer" "insdel" "textprop" "cmds")) + (:file "undo" :depends-on ("commands" "window")) + (:file "syntax" :depends-on ("buffer")) + (:file "major-mode" :depends-on ("keymap" "syntax")) + (:file "keyboard" :depends-on ("commands" "keymap" "subprocesses" "render")) + (:file "debugger" :depends-on ("commands" "major-mode")) + (:file "recursive-edit" :depends-on ("keyboard" "render" "debugger")) + (:file "minibuffer" :depends-on ("buffer" "window" "recursive-edit" "wm")) + (:file "files" :depends-on ("buffer" "buffer-local" "commands" "custom")) + (:file "help" :depends-on ("buffer" "commands")) + (:file "debug" :depends-on ("buffer" "commands")) + (:file "tty-render" :depends-on ("buffer" "window" "frame" "render")) + (:file "main" :depends-on ("buffer" "major-mode" "tty-render")) + ;; the following are files outside of lice-base + (:file "subr" :depends-on ("commands" "buffer")) + (:file "simple" :depends-on ("subr" "commands" "keymap" "major-mode" "custom")) + (:file "indent" :depends-on ("subr" "simple")) + (:file "lisp-mode" :depends-on ("indent" "simple")) + (:file "lisp-indent" :depends-on ("lisp-mode" "indent" "simple")) + (:file "paragraphs" :depends-on ("simple")) + (:file "text-mode" :depends-on ("simple" "paragraphs")) + (:file "doctor" :depends-on ("simple" "paragraphs" "text-mode")) + )) diff --git a/lisp-mode.lisp b/lisp-mode.lisp index ecd0d13..41856dd 100644 --- a/lisp-mode.lisp +++ b/lisp-mode.lisp @@ -59,15 +59,39 @@ See function `beginning-of-defun'." (make-instance 'major-mode :name "Lisp Interaction" :map (let ((m (make-sparse-keymap))) - (define-key m (make-key :char #\j :control t) 'eval-print-last-sexp) + (define-key m (kbd "C-j") 'eval-print-last-sexp) (define-key m (make-key :char #\Tab) 'lisp-indent-line) - (define-key m (make-key :char #\i :control t) 'lisp-indent-line) - (define-key m (make-key :char #\q :control t :meta t) 'indent-sexp) - (define-key m (make-key :char #\x :control t :meta t) 'eval-defun) + (define-key m (kbd "C-i") 'lisp-indent-line) + (define-key m (kbd "C-M-q") 'indent-sexp) + (define-key m (kbd "C-M-x") 'eval-defun) m) :syntax-table *lisp-mode-syntax-table*) "Lisp mode.") +(defvar *lisp-mode* + (make-instance 'major-mode + :name "Lisp" + :map (let ((m (make-sparse-keymap))) + (define-key m (make-key :char #\Tab) 'lisp-indent-line) + (define-key m (kbd "C-i") 'lisp-indent-line) + (define-key m (kbd "C-M-q") 'indent-sexp) + (define-key m (kbd "C-M-x") 'eval-defun) + m) + :syntax-table *lisp-mode-syntax-table*)) + +(defcommand lisp-mode () + "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. +Commands: +Delete converts tabs to spaces as it moves back. +Blank lines separate paragraphs. Semicolons start comments. +\\{lisp-mode-map} +Note that `run-lisp' may be used either to start an inferior Lisp job +or to switch back to an existing one. + +Entry to this mode calls the value of `lisp-mode-hook' +if that value is non-nil." + (set-major-mode '*lisp-mode*)) + (defun buffer-end (arg) "Return the \"far end\" position of the buffer, in direction ARG. If ARG is positive, that's the end of the buffer. @@ -198,7 +222,7 @@ Negative arg -N means move forward across N groups of parentheses." (error (c) (message "Eval error: ~a" c))))) (defcommand lisp-interaction-mode () - (set-major-mode *lisp-interaction-mode*)) + (set-major-mode '*lisp-interaction-mode*)) (defvar *lisp-indent-offset* nil "If non-nil, indent second line of expressions that many more columns.") diff --git a/main.lisp b/main.lisp index c8dae90..08769f8 100644 --- a/main.lisp +++ b/main.lisp @@ -1,9 +1,27 @@ -(in-package :lice) +(in-package "LICE") ;; #+cmu (setf extensions:*gc-notify-after* (lambda (&rest r)) extensions:*gc-notify-before* (lambda (&rest r))) +(defun init-mode-line-format () + (setf *default-mode-line-format* + (list "--:" ;; fake it for hype + (lambda (buffer) + (format nil "~C~C" + ;; FIXME: add read-only stuff + (if (buffer-modified-p buffer) + #\* #\-) + (if (buffer-modified-p buffer) + #\* #\-))) + " " + (lambda (buffer) + (format nil "~12,,,a" (buffer-name buffer))) + " " + (lambda (buffer) + (format nil "(~a)" + (major-mode-name (symbol-value (buffer-major-mode buffer)))))))) + (defun lice () "Run the lice environment." (unwind-protect @@ -13,7 +31,9 @@ #+clisp (init-clisp) (setf *buffer-list* nil) #+movitz (init-commands) + (init-mode-line-format) (make-default-buffers) + (set-buffer (get-buffer "*messages*")) ;; for the scratch buffer (set-buffer (get-buffer "*scratch*")) (insert *initial-scratch-message*) @@ -21,13 +41,13 @@ (setf (buffer-modified-p (current-buffer)) nil (buffer-undo-list (current-buffer)) nil) (goto-char (point-min)) - (set-major-mode *lisp-interaction-mode*) + (set-major-mode '*lisp-interaction-mode*) (init-command-arg-types) (setf *frame-list* (list #+(or cmu sbcl) (make-default-tty-frame (get-buffer "*scratch*")) #+clisp (make-default-clisp-frame (get-buffer "*scratch*")) #+mcl (make-default-mcl-frame (get-buffer "*scratch*")) #+movitz (make-default-movitz-frame (get-buffer "*scratch*"))) - *current-frame* (car *frame-list*) + *selected-frame* (car *frame-list*) *process-list* nil) (make-global-keymaps) (catch 'lice-quit diff --git a/major-mode.lisp b/major-mode.lisp index 8d52237..12d3ac6 100644 --- a/major-mode.lisp +++ b/major-mode.lisp @@ -1,6 +1,6 @@ ;;; Implement the major mode system -(in-package :lice) +(in-package "LICE") (defclass major-mode () ((name :type string :initarg :name :accessor major-mode-name) @@ -21,4 +21,24 @@ :init nil) (:documentation "A Major Mode class.")) +(defun set-major-mode (mm) + "Set the current buffer's major mode." + (check-type mm symbol) + (let ((mode (symbol-value mm))) + ;; Call All inherited init functions + (mapc 'set-major-mode (major-mode-inherit-init mode)) + + (when (major-mode-map mode) + (use-local-map (major-mode-map mode))) + (when (major-mode-syntax-table mode) + (set-syntax-table (major-mode-syntax-table mode))) + + ;; Now call this mm's init function + (when (major-mode-init mode) + (funcall (major-mode-init mode))) + + ;; Finally, set the mode and call the hook + (setf (buffer-major-mode (current-buffer)) mm) + (run-hooks (major-mode-hook mode)))) + (provide :lice-0.1/major-mode) diff --git a/mcl-render.lisp b/mcl-render.lisp index d9f9b51..bf89177 100644 --- a/mcl-render.lisp +++ b/mcl-render.lisp @@ -1,4 +1,4 @@ -(in-package :lice) +(in-package "LICE") (defclass mcl-window (ccl:window) ()) @@ -255,7 +255,7 @@ hardware.") :width cols :height lines :window-tree (list w mb) - :current-window w + :selected-window w :minibuffer-window mb :double-buffer l :2d-double-buffer d diff --git a/minibuffer.lisp b/minibuffer.lisp index 2473116..718dd6b 100644 --- a/minibuffer.lisp +++ b/minibuffer.lisp @@ -1,4 +1,4 @@ -(in-package :lice) +(in-package "LICE") (defvar *history-length* 30 "Maximum length for history lists before truncation takes place. @@ -11,9 +11,6 @@ property of a history variable overrides this default.") This is nil if there have not yet been any history commands in this use of the minibuffer.") -(defclass minibuffer-window (window) - ()) - (defvar *minibuffer-local-map* (let ((m (make-sparse-keymap))) (define-key m (make-key :char #\m :control t) 'exit-minibuffer) @@ -94,17 +91,26 @@ is added with (defvar *minibuffer-completion-predicate* nil "Within call to `completing-read', this holds the PREDICATE argument.") +(defvar *minibuffer-list* nil + "List of buffers for use as minibuffers. +The first element of the list is used for the outermost minibuffer +invocation, the next element is used for a recursive minibuffer +invocation, etc. The list is extended at the end as deeper +minibuffer recursions are encountered.") + (defun minibufferp (&optional (buffer (current-buffer))) - ;; FIXME: implement - nil) + "Return t if BUFFER is a minibuffer. +No argument or nil as argument means use current buffer as BUFFER. +BUFFER can be a buffer or a buffer name." + (and (find buffer *minibuffer-list*) t)) -(defun make-minibuffer (major-mode) +(defun make-minibuffer (map) "Return a fresh minibuffer with major mode, MAJOR-MODE." ;; FIXME: Emacs prefixes it with a space so it doesn't show up in ;; buffer listings. How are we gonna do this? (let ((mb (get-buffer-create (generate-new-buffer-name " *minibuffer*")))) - (setf (buffer-major-mode mb) major-mode - (buffer-mode-line mb) nil) + (setf (buffer-local-map mb) map + (buffer-local '*mode-line-format* mb) nil) mb)) (defun make-minibuffer-window (height cols) @@ -117,7 +123,7 @@ is added with :bottom-line 0 :point-col 0 :point-line 0 - :buffer (make-minibuffer *minibuffer-read-mode*) + :buffer (make-minibuffer *minibuffer-local-map*) :top (make-marker) :bottom (make-marker) :bpoint (make-marker) @@ -204,7 +210,7 @@ MINIBUF must be a minibuffer." (when (< end (zv minibuf)) (delete-region end (zv minibuf))))) -(defun setup-minibuffer-for-read (major-mode prompt initial-contents history) +(defun setup-minibuffer-for-read (map prompt initial-contents history) (save-window-excursion ;; Create a new minibuffer (let* ((frame (selected-frame)) @@ -212,8 +218,8 @@ MINIBUF must be a minibuffer." (*minibuffer-history-position* 0) (*minibuffer-text-before-history* nil) (old-minibuffer (window-buffer (frame-minibuffer-window frame))) - (new-minibuffer (make-minibuffer major-mode))) - (window-save-point (get-current-window)) + (new-minibuffer (make-minibuffer map))) + (window-save-point (selected-window)) ;; attach it to the current frame (set-window-buffer (frame-minibuffer-window frame) new-minibuffer) (select-window (frame-minibuffer-window frame)) @@ -318,7 +324,7 @@ one puts point at the beginning of the string. *Note* that this behavior differs from the way such arguments are used in `completing-read' and some related functions, which use zero-indexing for POSITION." (declare (ignore default-value read keymap)) - (setup-minibuffer-for-read *minibuffer-read-mode* prompt initial-contents history)) + (setup-minibuffer-for-read (or keymap *minibuffer-local-map*) prompt initial-contents history)) (defun tree-find (tree obj &key (test #'eq)) "find OBJ in TREE. Return the OBJ or nil." @@ -466,7 +472,7 @@ and some related functions, which use zero-indexing for POSITION." (insert (subseq match (length txt)))))))) (defun completing-read (prompt table &key predicate require-match - initial-input (history '*minibuffer-history*) def) + initial-input (history '*minibuffer-history*) def) "Read a string in the minibuffer, with completion. PROMPT is a string to prompt with; normally it ends in a colon and a space. TABLE is an alist whose elements' cars are strings, or an obarray. @@ -498,8 +504,8 @@ DEF, if non-nil, is the default value." (let ((*minibuffer-completion-table* table) (*minibuffer-completion-predicate* predicate)) (setup-minibuffer-for-read (if require-match - *minibuffer-must-match-mode* - *minibuffer-complete-mode*) + *minibuffer-local-must-match-map* + *minibuffer-local-completion-map*) prompt initial-input history))) ;; (defun y-or-n-p (prompt) diff --git a/movitz-render.lisp b/movitz-render.lisp index 6d25470..3c25fac 100644 --- a/movitz-render.lisp +++ b/movitz-render.lisp @@ -1,8 +1,8 @@ -(in-package :lice) +(in-package "LICE") ;; TTY rendering routines -(in-package :lice) +(in-package "LICE") (defclass movitz-frame (frame) ((double-buffer :type (array character 1) :initarg :double-buffer :accessor frame-double-buffer :documentation @@ -211,7 +211,7 @@ the text properties present." :width cols :height lines :window-tree (list w mb) - :current-window w + :selected-window w :minibuffer-window mb :double-buffer l ;; :2d-double-buffer d diff --git a/recursive-edit.lisp b/recursive-edit.lisp index d03d0e5..35ae865 100644 --- a/recursive-edit.lisp +++ b/recursive-edit.lisp @@ -1,6 +1,6 @@ ;;; Implement the recursive edit. -(in-package :lice) +(in-package "LICE") (defvar *recursive-edit-depth* 0 "The current recursive-edit depth.") diff --git a/render.lisp b/render.lisp new file mode 100644 index 0000000..3270c87 --- /dev/null +++ b/render.lisp @@ -0,0 +1,46 @@ +;;; frame rendering routines + +(in-package "LICE") + +;; The defmethods are found in the *-render.lisp files +(defgeneric frame-start-render (frame) + (:documentation "Do any setup we need before we beginning rendering the frame.")) + +(defgeneric frame-end-render (frame) + (:documentation "Do any cleanup or refreshing after the frame is rendered.")) + +;; the defmethods are found in the *-render.lisp files +(defgeneric window-render (window frame) + (:documentation "Render the window in the given frame.")) + +(defgeneric frame-read-event (frame) + (:documentation "Read a keyboard event for the specified frame.")) + +(defgeneric frame-move-cursor (frame window x y) + (:documentation "Move the cursor to the X,Y location in WINDOW on the frame, FRAME.")) + +(defun frame-render (frame) + "Render a frame." + (let (cursor-x cursor-y win) + (labels ((render (tree) + (cond ((null tree) nil) + ((atom tree) + ;; reset the cache + (window-reset-cache tree) + ;; Figure out what part to display + (window-framer tree + (window-point tree) + (truncate (window-height tree) 2)) + (dformat +debug-vvv+ "after framer: ~a~%" + (lc-cache (window-cache tree))) + ;; display it + (multiple-value-bind (x y) (window-render tree frame) + (when (eq tree (frame-selected-window frame)) + (setf win tree cursor-x x cursor-y y)))) + (t (cons (render (car tree)) + (render (cdr tree))))))) + (frame-start-render frame) + (render (frame-window-tree frame)) + (when (and win cursor-x cursor-y) + (frame-move-cursor frame win cursor-x cursor-y)) + (frame-end-render frame)))) diff --git a/search.lisp b/search.lisp index f6c86f2..d1215c8 100644 --- a/search.lisp +++ b/search.lisp @@ -1,4 +1,4 @@ -(in-package :lice) +(in-package "LICE") ;; because gnu emacs' match-data is not reentrant we create this ;; structure that is returned for all searching functions. It is @@ -83,14 +83,14 @@ Zero means the entire text matched by the whole regexp or whole string." ((null error) nil) (bound - (goto-char bound buffer) + (set-point bound buffer) nil) (t nil)) (progn (if (minusp count) - (goto-char (+ (buffer-aref-to-char buffer pos) (length string))) - (goto-char (buffer-aref-to-char buffer pos))) - (values (point) + (set-point (+ (buffer-aref-to-char buffer pos) (length string))) + (set-point (buffer-aref-to-char buffer pos))) + (values (pt) (setf *match-data* (make-match-data :obj buffer :start (buffer-aref-to-char buffer pos) @@ -129,24 +129,27 @@ Search case-sensitivity is determined by the value of the variable See also the functions `match-beginning', `match-end' and `replace-match'." (string-search-command string bound error count -1)) +(defvar *regexp-cache* (make-memoize-state :test 'string=)) + ;; TODO: create compiler-macros for regex functions so the regexps can ;; be compiled at compile time. (defun looking-at (regexp &optional (buffer (current-buffer))) "Return the match-data if text after point matches regular expression regexp." + (check-type regexp string) (check-search-thread-safe) ;; get the gap outta the way. It sucks we have to do this. Really we ;; should modify ppcre to generate scanner functions that hop the ;; gap. Meantime... - (when (< (buffer-char-to-aref buffer (point buffer)) + (when (< (buffer-char-to-aref buffer (pt buffer)) (buffer-gap-start buffer)) (gap-move-to-point buffer)) (multiple-value-bind (start end reg-starts reg-ends) - (ppcre:scan (ppcre:create-scanner regexp :multi-line-mode t) (buffer-data buffer) - :start (buffer-char-to-aref buffer (point buffer)) + (ppcre:scan (memoize *regexp-cache* regexp (ppcre:create-scanner regexp :multi-line-mode t)) (buffer-data buffer) + :start (buffer-char-to-aref buffer (pt buffer)) :real-start-pos 0) (when (and start - (= start (buffer-char-to-aref buffer (point buffer)))) + (= start (buffer-char-to-aref buffer (pt buffer)))) (values t (setf *match-data* (make-match-data :obj buffer @@ -171,17 +174,17 @@ See also the functions `match-beginning', `match-end', `match-string', and `replace-match'." (declare (ignore count)) (check-search-thread-safe) - (when (< (buffer-char-to-aref buffer (point buffer)) + (when (< (buffer-char-to-aref buffer (pt buffer)) (buffer-gap-start buffer)) (gap-move-to-point buffer)) (multiple-value-bind (start end reg-starts reg-ends) - (ppcre:scan (ppcre:create-scanner regexp :multi-line-mode t) (buffer-data buffer) - :start (buffer-char-to-aref buffer (point buffer)) + (ppcre:scan (memoize *regexp-cache* regexp (ppcre:create-scanner regexp :multi-line-mode t)) (buffer-data buffer) + :start (buffer-char-to-aref buffer (pt buffer)) :end (buffer-char-to-aref buffer bound) :real-start-pos 0) (cond (start - (goto-char (buffer-aref-to-char buffer end) buffer) - (values (point) + (set-point (buffer-aref-to-char buffer end) buffer) + (values (pt) (setf *match-data* (make-match-data :obj buffer :start (buffer-aref-to-char buffer start) @@ -197,7 +200,7 @@ and `replace-match'." ((null error) nil) (bound - (goto-char bound buffer) + (set-point bound buffer) nil) (t nil)))) @@ -217,19 +220,19 @@ and `replace-match'." (check-search-thread-safe) ;;(message "re-search-backward ~s ~d" regexp (point)) (when (> (buffer-gap-start buffer) - (buffer-char-to-aref buffer (point buffer))) - (gap-move-to buffer (buffer-char-to-aref buffer (1+ (point buffer))))) + (buffer-char-to-aref buffer (pt buffer))) + (gap-move-to buffer (buffer-char-to-aref buffer (1+ (pt buffer))))) ;; start search from point and keep walking back til we match something - (let* ((start-aref (buffer-char-to-aref buffer (point buffer))) + (let* ((start-aref (buffer-char-to-aref buffer (pt buffer))) (pt-aref start-aref) (stop (buffer-char-to-aref buffer bound)) - (scanner (ppcre:create-scanner regexp :multi-line-mode t))) + (scanner (memoize *regexp-cache* regexp (ppcre:create-scanner regexp :multi-line-mode t)))) (loop (multiple-value-bind (start end reg-starts reg-ends) (ppcre:scan scanner (buffer-data buffer) :start start-aref :end pt-aref :real-start-pos 0) (when start - (goto-char (buffer-aref-to-char buffer start) buffer) - (return (values (point) + (set-point (buffer-aref-to-char buffer start) buffer) + (return (values (pt) (setf *match-data* (make-match-data :obj buffer :start (buffer-aref-to-char buffer start) @@ -249,7 +252,7 @@ and `replace-match'." (return nil)) (t (when bound - (goto-char bound buffer)) + (set-point bound buffer)) (return nil)))))))) (defun string-match (regexp string &key (start 0) (end (length string))) @@ -265,7 +268,7 @@ You can use the function `match-string' to extract the substrings matched by the parenthesis constructions in regexp." (check-search-thread-safe) (multiple-value-bind (start end reg-starts reg-ends) - (ppcre:scan (ppcre:create-scanner regexp :multi-line-mode t) + (ppcre:scan (memoize *regexp-cache* regexp (ppcre:create-scanner regexp :multi-line-mode t)) string :start start :end end) (when start (values start @@ -285,3 +288,156 @@ matched by the parenthesis constructions in regexp." collect #\\ collect c) 'string)) + +(defun scan-buffer (buffer target start end count) +"Search for COUNT instances of the character TARGET between START and END. + +If COUNT is positive, search forwards; END must be >= START. +If COUNT is negative, search backwards for the -COUNTth instance; + END must be <= START. +If COUNT is zero, do anything you please; run rogue, for all I care. + +If END is NIL, use BEGV or ZV instead, as appropriate for the +direction indicated by COUNT. + +If we find COUNT instances, return the +position past the COUNTth match and 0. Note that for reverse motion +this is not the same as the usual convention for Emacs motion commands. + +If we don't find COUNT instances before reaching END, return END +and the number of TARGETs left unfound." + (let ((shortage (abs count)) + last) + (if (> count 0) + (setf end (or end (zv buffer))) + (setf end (or end (begv buffer)))) + (setf start (buffer-char-to-aref buffer start) + end (buffer-char-to-aref buffer end)) + (loop while (and (> count 0) + (/= start end)) do + (setf start + (if (< start (buffer-gap-start buffer)) + (or (position target (buffer-data buffer) :start start :end (min end (buffer-gap-start buffer))) + (and (> end (gap-end buffer)) + (position target (buffer-data buffer) :start (gap-end buffer) :end end))) + (position target (buffer-data buffer) :start start :end end))) + (if start + (setf start (1+ start) + last start + count (1- count) + shortage (1- shortage)) + (setf start end))) + (loop while (and (< count 0) + (/= start end)) do + (setf start + (if (> start (buffer-gap-start buffer)) + (or (position target (buffer-data buffer) :start (max end (gap-end buffer)) :end start :from-end t) + (and (< end (buffer-gap-start buffer)) + (position target (buffer-data buffer) :start end :end (buffer-gap-start buffer) :from-end t))) + (position target (buffer-data buffer) :start end :end start :from-end t))) + (if start + (setf last (+ start 1) ; match emacs functionality + count (1+ count) + shortage (1- shortage)) + (setf start end))) + (if (zerop count) + (values (and last (buffer-aref-to-char buffer last)) 0) + (values (buffer-aref-to-char buffer end) shortage)))) + +(defun find-before-next-newline (from to cnt) + "Like find_next_newline, but returns position before the newline, +not after, and only search up to TO. This isn't just +find_next_newline (...)-1, because you might hit TO." + (multiple-value-bind (pos shortage) (scan-buffer (current-buffer) #\Newline from to cnt) + (when (zerop shortage) + (decf pos)) + pos)) + +(defun buffer-scan-newline (buf start limit count) + "Search BUF for COUNT newlines with a limiting point at LIMIT, +starting at START. Returns the point of the last newline or limit and +number of newlines found. START and LIMIT are inclusive." + (declare (type buffer buf) + (type integer start limit count)) + (labels ((buffer-scan-bk (buf start limit count) + "count is always >=0. start >= limit." + (let* ((start-aref (buffer-char-to-aref buf start)) + (limit-aref (buffer-char-to-aref buf limit)) + (ceiling (if (>= start-aref (gap-end buf)) + (max limit-aref (gap-end buf)) + limit-aref)) + (i 0) + ;; :END is not inclusive but START is. + (start (1+ start-aref)) + p) + (loop + ;; Always search at least once + (setf p (position #\Newline (buffer-data buf) + :start ceiling :end start :from-end t)) + (if p + (progn + ;; Move start. Note that start isn't set to (1+ p) + ;; because we don't want to search p again. + (setf start p) + ;; Count the newline + (incf i) + ;; Have we found enough newlines? + (when (>= i count) + (return-from buffer-scan-bk (values (buffer-aref-to-char buf p) + i)))) + ;; Check if we've searched up to the limit + (if (= ceiling limit-aref) + (return-from buffer-scan-bk (values limit i)) + ;; if not, skip past the gap + (progn + (setf ceiling limit-aref) + (setf start (buffer-gap-start buf)))))))) + (buffer-scan-fw (buf start limit count) + "count is always >=0. start >= limit." + (let* ((start-aref (buffer-char-to-aref buf start)) + (limit-aref (1+ (buffer-char-to-aref buf limit))) + (ceiling (if (< start (buffer-gap-start buf)) + (min limit-aref (buffer-gap-start buf)) + limit-aref)) + (i 0) + (start start-aref) + p) + (loop + ;; Always search at least once + (setf p (position #\Newline (buffer-data buf) :start start :end ceiling)) + (if p + (progn + ;; Move start. We don't want to search p again, thus the 1+. + (setf start (1+ p)) + ;; Count the newline + (incf i) + ;; Have we found enough newlines? + (when (>= i count) + (return-from buffer-scan-fw (values (buffer-aref-to-char buf p) + i)))) + ;; Check if we've searched up to the limit + (if (= ceiling limit-aref) + (return-from buffer-scan-fw (values limit i)) + ;; if not, skip past the gap + (progn + (setf ceiling limit-aref) + (setf start (gap-end buf))))))))) + ;; make sure start and limit are within the bounds + (setf start (max 0 (min start (1- (buffer-size buf)))) + limit (max 0 (min limit (1- (buffer-size buf))))) + ;; the search always fails on an empty buffer + (when (= (buffer-size buf) 0) + (return-from buffer-scan-newline (values limit 0))) + (cond ((> count 0) + (dformat +debug-vv+ "scan-fw ~a ~a ~a~%" start limit count) + (buffer-scan-fw buf start limit count)) + ((< count 0) + (dformat +debug-vv+ "scan-bk ~a ~a ~a~%" start limit count) + (buffer-scan-bk buf start limit (abs count))) + ;; 0 means the newline before the beginning of the current + ;; line. We need to handle the case where we are on a newline. + (t + (dformat +debug-vv+ "scan-0 ~a ~a ~a~%" start limit count) + (if (char= (buffer-char-after buf start) #\Newline) + (buffer-scan-bk buf start limit 2) + (buffer-scan-bk buf start limit 1)))))) diff --git a/simple.lisp b/simple.lisp index 883f558..158a8f0 100644 --- a/simple.lisp +++ b/simple.lisp @@ -1,4 +1,4 @@ -(in-package :lice) +(in-package "LICE") (defvar *kill-ring* nil "The kill ring.") @@ -39,20 +39,7 @@ If nil, don't change the value of `debug-on-error'." ;; (point-max))) ;; (decf (marker-position (buffer-point (current-buffer))) n)) -(defcommand forward-char ((&optional (n 1)) - :prefix) - "Move the point forward N characters in the current buffer." - (incf (marker-position (buffer-point (current-buffer))) n) - (cond ((< (point) (begv)) - (goto-char (begv)) - (signal 'beginning-of-buffer)) - ((> (point) (zv)) - (goto-char (zv)) - (signal 'end-of-buffer)))) - -(defcommand backward-char ((&optional (n 1)) - :prefix) - (forward-char (- n))) + (defun buffer-beginning-of-line () "Return the point in the buffer that is the beginning of the line that P is on." @@ -78,66 +65,6 @@ If nil, don't change the value of `debug-on-error'." eol (1+ eol))))) -(defun forward-line (n) - "Move n lines forward (backward if n is negative). -Precisely, if point is on line I, move to the start of line I + n. -If there isn't room, go as far as possible (no error). -Returns the count of lines left to move. If moving forward, -that is n - number of lines moved; if backward, n + number moved. -With positive n, a non-empty line at the end counts as one line - successfully moved (for the return value)." - (cond ((and (> n 0) - (= (point) (zv))) - (signal 'end-of-buffer)) - ((and (< n 0) - (= (point) (begv))) - (signal 'beginning-of-buffer))) - (if (> n 0) - (multiple-value-bind (p lines) (buffer-scan-newline (current-buffer) - (point (current-buffer)) - (1- (buffer-size (current-buffer))) - n) - ;; Increment p by one so the point is at the beginning of the - ;; line. - (when (or (char= (char-after p) #\Newline) - (= p (1- (buffer-size (current-buffer))))) - (incf p)) - (goto-char p) - (when (zerop lines) - (signal 'end-of-buffer)) - (- n lines)) - (if (and (= n 0) - (not (char-before))) - 0 - ;; A little mess to figure out how many newlines to search - ;; for to give the proper output. - (let ((lines (if (and (char-after (point)) - (char= (char-after (point)) #\Newline)) - (- n 2) - (1- n)))) - (multiple-value-bind (p flines) - (buffer-scan-newline (current-buffer) - (point) (begv) - lines) - (when (and (char= (char-after p) #\Newline) - (= flines (- lines))) - (incf p)) - (goto-char p) - (when (and (< n 0) - (zerop flines)) - (signal 'beginning-of-buffer)) - (+ n flines)))))) - -(defcommand self-insert-command ((arg) - :prefix) - "Insert the character you type. -Whichever character you type to run this command is inserted." - (dformat +debug-v+ "currentb: ~a ~a~%" (current-buffer) *current-buffer*) - (if (>= arg 2) - (insert-move-point (current-buffer) (make-string arg :initial-element (key-char *current-event*))) - (when (> arg 0) - (insert-move-point (current-buffer) (key-char *current-event*))))) - (defcommand newline ((&optional n) :prefix) "Insert N new lines." @@ -174,14 +101,6 @@ With arg N, insert N newlines." (goto-char (+ (point) col)) (goto-char (buffer-end-of-line))))) -(defcommand delete-backward-char () - "Delete the previous N characters." - (buffer-delete (current-buffer) (point (current-buffer)) -1)) - -(defcommand delete-char () - "Delete the following N characters." - (buffer-delete (current-buffer) (point (current-buffer)) 1)) - (defun line-move-invisible-p (pos) "Return non-nil if the character after POS is currently invisible." (let ((prop @@ -560,10 +479,6 @@ to t." (t (return)))) nil)) -(defcommand erase-buffer ((&optional (buffer (current-buffer)))) - "Erase the contents of the current buffer." - (buffer-erase buffer)) - (defcommand execute-extended-command ((prefix) :raw-prefix) "Read a user command from the minibuffer." @@ -596,7 +511,7 @@ within a Lisp program! Use `set-buffer' instead. That avoids messing with the window-buffer correspondences." (unless buffer (setf buffer (other-buffer (current-buffer)))) - (let ((w (frame-current-window (selected-frame)))) + (let ((w (frame-selected-window (selected-frame)))) (when (typep w 'minibuffer-window) (error "its a minibuffer")) (setf buffer (get-buffer-create buffer)) @@ -609,32 +524,6 @@ the window-buffer correspondences." ;; TODO: save-some-buffers (throw 'lice-quit t)) -(defcommand kill-buffer ((buffer) - (:buffer "Kill buffer: " (buffer-name (current-buffer)) t)) - "Kill the buffer BUFFER. -The argument may be a buffer or may be the name of a buffer. -defaults to the current buffer. - -Value is t if the buffer is actually killed, nil if user says no. - -The value of `kill-buffer-hook' (which may be local to that buffer), -if not void, is a list of functions to be called, with no arguments, -before the buffer is actually killed. The buffer to be killed is current -when the hook functions are called. - -Any processes that have this buffer as the `process-buffer' are killed -with SIGHUP." - (let* ((target (get-buffer buffer)) - (other (other-buffer target))) - (if target - (progn - ;; all windows carrying the buffer need a new buffer - (loop for w in (frame-window-list (selected-frame)) - do (when (eq (window-buffer w) target) - (set-window-buffer w other))) - (setf *buffer-list* (delete target *buffer-list*))) - (error "No such buffer ~a" buffer)))) - (defun eval-echo (string) ;; FIXME: don't just abandon the output (let* ((stream (make-string-output-stream)) @@ -693,14 +582,14 @@ In Transient Mark mode, this does not activate the mark." (defcommand scroll-up ((&optional arg) :raw-prefix) - (let ((win (get-current-window))) + (let ((win (selected-window))) (window-scroll-up win (max 1 (or (and arg (prefix-numeric-value arg)) (- (window-height win) *next-screen-context-lines*)))))) (defcommand scroll-down ((&optional arg) :raw-prefix) - (let ((win (get-current-window))) + (let ((win (selected-window))) (window-scroll-down win (max 1 (or (and arg (prefix-numeric-value arg)) (- (window-height win) *next-screen-context-lines*)))))) @@ -740,20 +629,14 @@ of the accessible part of the buffer." (goto-char (point-min))) (defcommand split-window-vertically () - (split-window (get-current-window))) + (split-window (selected-window))) (defcommand split-window-horizontally () - (split-window (get-current-window) nil t)) - -(defcommand other-window () - (let ((w (next-window (get-current-window) t))) - (if w - (select-window w) - (message "No other window.")))) + (split-window (selected-window) nil t)) (defcommand switch-to-buffer-other-window ((buffer) (:buffer "Switch to buffer in other window: " (buffer-name (other-buffer (current-buffer))))) - (let* ((cw (get-current-window)) + (let* ((cw (selected-window)) (w (or (next-window cw) (split-window cw)))) (select-window w) @@ -1129,6 +1012,9 @@ With argument 0, interchanges line point is in with line mark is in." "Major mode not specialized for anything in particular. Other major modes are defined by comparison with this one.") +(defun fundamental-mode () + (set-major-mode '*fundamental-mode*)) + (defun turn-on-auto-fill () "Unconditionally turn on Auto Fill mode." ;; FIXME: implement @@ -1361,4 +1247,451 @@ will pop twice." ;; Move back over chars that have whitespace syntax but have the p flag. (backward-prefix-chars)) + +;;; undo + +;; XXX: gnu emacs uses a weak hashtable that automatically removes +;; references. We need some mechanism to do similar. +(defvar undo-equiv-table (make-hash-table :test 'eq #|:weakness t|#) + "Table mapping redo records to the corresponding undo one. +A redo record for undo-in-region maps to t. +A redo record for ordinary undo maps to the following (earlier) undo.") + +(defvar undo-in-region nil + "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.") + +(defvar undo-no-redo nil + "If t, `undo' doesn't go through redo entries.") + +(defvar pending-undo-list nil + "Within a run of consecutive undo commands, list remaining to be undone. +If t, we undid all the way to the end of it.") + +(defcommand undo ((&optional arg) + ;; XXX: what about the *? + :raw-prefix) + "Undo some previous changes. +Repeat this command to undo more changes. +A numeric argument serves as a repeat count. + +In Transient Mark mode when the mark is active, only undo changes within +the current region. Similarly, when not in Transient Mark mode, just \\[universal-argument] +as an argument limits undo to changes within the current region." + ;;(interactive "*P") + ;; Make last-command indicate for the next command that this was an undo. + ;; That way, another undo will undo more. + ;; If we get to the end of the undo history and get an error, + ;; another undo command will find the undo history empty + ;; and will get another error. To begin undoing the undos, + ;; you must type some other command. + (let ((modified (buffer-modified-p (current-buffer))) + (recent-save (recent-auto-save-p)) + message) + ;; If we get an error in undo-start, + ;; the next command should not be a "consecutive undo". + ;; So set `this-command' to something other than `undo'. + (setq *this-command* 'undo-start) + + (unless (and (eq *last-command* 'undo) + (or (eq pending-undo-list t) + ;; If something (a timer or filter?) changed the buffer + ;; since the previous command, don't continue the undo seq. + (let ((list (buffer-undo-list (current-buffer)))) + (while (eq (car list) nil) + (setq list (cdr list))) + ;; If the last undo record made was made by undo + ;; it shows nothing else happened in between. + (gethash list undo-equiv-table)))) + (message "guuuungh") + (setq undo-in-region + (if transient-mark-mode *mark-active* (and arg (not (numberp arg))))) + (if undo-in-region + (undo-start (region-beginning) (region-end)) + (undo-start)) + ;; get rid of initial undo boundary + (undo-more 1)) + ;; If we got this far, the next command should be a consecutive undo. + (setq *this-command* 'undo) + ;; Check to see whether we're hitting a redo record, and if + ;; so, ask the user whether she wants to skip the redo/undo pair. + (let ((equiv (gethash pending-undo-list undo-equiv-table))) + (or (eq (selected-window) (minibuffer-window)) + (setq message (if undo-in-region + (if equiv "Redo in region!" "Undo in region!") + (if equiv "Redo!" "Undo!")))) + (when (and (consp equiv) undo-no-redo) + ;; The equiv entry might point to another redo record if we have done + ;; undo-redo-undo-redo-... so skip to the very last equiv. + (while (let ((next (gethash equiv undo-equiv-table))) + (if next (setq equiv next)))) + (setq pending-undo-list equiv))) + (undo-more + (if (or transient-mark-mode (numberp arg)) + (prefix-numeric-value arg) + 1)) + ;; Record the fact that the just-generated undo records come from an + ;; undo operation--that is, they are redo records. + ;; In the ordinary case (not within a region), map the redo + ;; record to the following undos. + ;; I don't know how to do that in the undo-in-region case. + (setf (gethash (buffer-undo-list (current-buffer)) undo-equiv-table) + (if undo-in-region t pending-undo-list)) + ;; Don't specify a position in the undo record for the undo command. + ;; Instead, undoing this should move point to where the change is. + (let ((tail (buffer-undo-list (current-buffer))) + (prev nil)) + (message "its: ~s" tail) + (while (car tail) + (when (integerp (car tail)) + (let ((pos (car tail))) + (if prev + (setf (cdr prev) (cdr tail)) + (setf (buffer-undo-list (current-buffer)) (cdr tail))) + (setq tail (cdr tail)) + (while (car tail) + (if (eql pos (car tail)) + (if prev + (setf (cdr prev) (cdr tail)) + (setf (buffer-undo-list (current-buffer)) (cdr tail))) + (setq prev tail)) + (setq tail (cdr tail))) + (setq tail nil))) + (setq prev tail + tail (cdr tail)))) + ;; Record what the current undo list says, + ;; so the next command can tell if the buffer was modified in between. + (and modified (not (buffer-modified-p (current-buffer))) + (delete-auto-save-file-if-necessary recent-save)) + ;; Display a message announcing success. + (if message + (message message)))) + +(defcommand buffer-disable-undo ((&optional buffer)) + "Make BUFFER stop keeping undo information. +No argument or nil as argument means do this for the current buffer." + (with-current-buffer (if buffer (get-buffer buffer) (current-buffer)) + (setf (buffer-undo-list (current-buffer)) t))) + +(defcommand undo-only ((&optional arg) + ;; XXX what about * + :prefix) + "Undo some previous changes. +Repeat this command to undo more changes. +A numeric argument serves as a repeat count. +Contrary to `undo', this will not redo a previous undo." + ;;(interactive "*p") + (let ((undo-no-redo t)) (undo arg))) + +(defvar undo-in-progress nil + "Non-nil while performing an undo. +Some change-hooks test this variable to do something different.") + +(defun undo-more (n) + "Undo back N undo-boundaries beyond what was already undone recently. +Call `undo-start' to get ready to undo recent changes, +then call `undo-more' one or more times to undo them." + (or (listp pending-undo-list) + (error (concat "No further undo information" + (and transient-mark-mode *mark-active* + " for region")))) + (let ((undo-in-progress t)) + (setq pending-undo-list (primitive-undo n pending-undo-list)) + (if (null pending-undo-list) + (setq pending-undo-list t)))) + +;; Deep copy of a list +(defun undo-copy-list (list) + "Make a copy of undo list LIST." + (labels ((helper (elt) + (if (typep elt 'structure-object) + (copy-structure elt) + elt))) + (mapcar #'helper list))) + +(defun undo-start (&optional beg end) + "Set `pending-undo-list' to the front of the undo list. +The next call to `undo-more' will undo the most recently made change. +If BEG and END are specified, then only undo elements +that apply to text between BEG and END are used; other undo elements +are ignored. If BEG and END are nil, all undo elements are used." + (if (eq (buffer-undo-list (current-buffer)) t) + (error "No undo information in this buffer")) + (setq pending-undo-list + (if (and beg end (not (= beg end))) + (undo-make-selective-list (min beg end) (max beg end)) + (buffer-undo-list (current-buffer))))) + +(defvar undo-adjusted-markers) + +(defun undo-make-selective-list (start end) + "Return a list of undo elements for the region START to END. +The elements come from `buffer-undo-list', but we keep only +the elements inside this region, and discard those outside this region. +If we find an element that crosses an edge of this region, +we stop and ignore all further elements." + (let ((undo-list-copy (undo-copy-list (buffer-undo-list (current-buffer)))) + (undo-list (list nil)) + undo-adjusted-markers + some-rejected + undo-elt temp-undo-list delta) + (while undo-list-copy + (setq undo-elt (car undo-list-copy)) + (let ((keep-this + (cond ((typep undo-elt 'undo-entry-modified) ;;(and (consp undo-elt) (eq (car undo-elt) t)) + ;; This is a "was unmodified" element. + ;; Keep it if we have kept everything thus far. + (not some-rejected)) + (t + (undo-elt-in-region undo-elt start end))))) + (if keep-this + (progn + (setq end (+ end (cdr (undo-delta undo-elt)))) + ;; Don't put two nils together in the list + (if (not (and (eq (car undo-list) nil) + (eq undo-elt nil))) + (setq undo-list (cons undo-elt undo-list)))) + (if (undo-elt-crosses-region undo-elt start end) + (setq undo-list-copy nil) + (progn + (setq some-rejected t) + (setq temp-undo-list (cdr undo-list-copy)) + (setq delta (undo-delta undo-elt)) + + (when (/= (cdr delta) 0) + (let ((position (car delta)) + (offset (cdr delta))) + + ;; Loop down the earlier events adjusting their buffer + ;; positions to reflect the fact that a change to the buffer + ;; isn't being undone. We only need to process those element + ;; types which undo-elt-in-region will return as being in + ;; the region since only those types can ever get into the + ;; output + + (dolist (undo-elt temp-undo-list) + (cond ((integerp undo-elt) + (if (>= undo-elt position) + (setf (car temp-undo-list) (- undo-elt offset)))) + ;;((atom undo-elt) nil) + ((typep undo-elt 'undo-entry-delete) ;(stringp (car undo-elt)) + ;; (TEXT . POSITION) + (let ((text-pos (abs (undo-entry-delete-position undo-elt))) + (point-at-end (< (undo-entry-delete-position undo-elt) 0 ))) + (if (>= text-pos position) + (setf (undo-entry-delete-position undo-elt) (* (if point-at-end -1 1) + (- text-pos offset)))))) + ((typep undo-elt 'undo-entry-insertion) ;(integerp (car undo-elt)) + ;; (BEGIN . END) + (when (>= (undo-entry-insertion-beg undo-elt) position) + (setf (undo-entry-insertion-beg undo-elt) (- (undo-entry-insertion-beg undo-elt) offset)) + (setf (undo-entry-insertion-end undo-elt) (- (undo-entry-insertion-end undo-elt) offset)))) + ((typep undo-elt 'undo-entry-property) ;(null (car undo-elt)) + ;; (nil PROPERTY VALUE BEG . END) + (when (>= (undo-entry-property-beg undo-elt) position) + (setf (undo-entry-property-beg undo-elt) (- (undo-entry-property-beg undo-elt) offset)) + (setf (undo-entry-property-end undo-elt) (- (undo-entry-property-end undo-elt) offset)))))))))))) + (setq undo-list-copy (cdr undo-list-copy))) + (nreverse undo-list))) + +(defun undo-elt-in-region (undo-elt start end) + "Determine whether UNDO-ELT falls inside the region START ... END. +If it crosses the edge, we return nil." + (cond ((integerp undo-elt) + (and (>= undo-elt start) + (<= undo-elt end))) + ((eq undo-elt nil) + t) +;; ((atom undo-elt) +;; nil) + ((typep undo-elt 'undo-entry-delete) ; (stringp (car undo-elt)) + ;; (TEXT . POSITION) + (and (>= (abs (undo-entry-delete-position undo-elt)) start) + (< (abs (undo-entry-delete-position undo-elt)) end))) + ((typep undo-elt 'undo-entry-marker) ;(and (consp undo-elt) (markerp (car undo-elt))) + ;; This is a marker-adjustment element (MARKER . ADJUSTMENT). + ;; See if MARKER is inside the region. + (let ((alist-elt (assq (undo-entry-marker-marker undo-elt) undo-adjusted-markers))) + (unless alist-elt + (setq alist-elt (make-undo-entry-marker :marker (undo-entry-marker-marker undo-elt) + :distance (marker-position (undo-entry-marker-marker undo-elt)))) + (setq undo-adjusted-markers + (cons alist-elt undo-adjusted-markers))) + (and (undo-entry-marker-distance alist-elt) ;(cdr alist-elt) + (>= (undo-entry-marker-distance alist-elt) start) + (<= (undo-entry-marker-distance alist-elt) end)))) + ((typep undo-elt 'undo-entry-property) ;(null (car undo-elt)) + ;; (nil PROPERTY VALUE BEG . END) + (and (>= (undo-entry-property-beg undo-elt) start) + (<= (undo-entry-property-end undo-elt) end))) + ((typep undo-elt 'undo-entry-insertion) ;(integerp (car undo-elt)) + ;; (BEGIN . END) + (and (>= (undo-entry-insertion-beg undo-elt) start) + (<= (undo-entry-insertion-end undo-elt) end))))) + +(defun undo-elt-crosses-region (undo-elt start end) + "Test whether UNDO-ELT crosses one edge of that region START ... END. +This assumes we have already decided that UNDO-ELT +is not *inside* the region START...END." + (cond ;; (atom undo-elt) nil) + ((typep undo-elt 'undo-entry-property) ;(null (car undo-elt)) + ;; (nil PROPERTY VALUE BEG . END) + ;;(let ((tail (nthcdr 3 undo-elt))) + (not (or (< (undo-entry-property-beg undo-elt) end) + (> (undo-entry-property-end undo-elt) start)))) + ((typep undo-elt 'undo-entry-insertion) ;(integerp (car undo-elt)) + ;; (BEGIN . END) + (not (or (< (undo-entry-insertion-beg undo-elt) end) + (> (undo-entry-insertion-end undo-elt) start)))))) + +;; Return the first affected buffer position and the delta for an undo element +;; delta is defined as the change in subsequent buffer positions if we *did* +;; the undo. +(defun undo-delta (undo-elt) + (cond ((typep undo-elt 'undo-entry-delete) ;(stringp (car undo-elt)) + ;; (TEXT . POSITION) + (cons (abs (undo-entry-delete-position undo-elt)) (length (undo-entry-delete-text undo-elt)))) + ((typep undo-elt 'undo-entry-insertion) ;(integerp (car undo-elt)) + ;; (BEGIN . END) + (cons (undo-entry-insertion-beg undo-elt) (- (undo-entry-insertion-beg undo-elt) (undo-entry-insertion-end undo-elt)))) + (t + '(0 . 0)))) + +(defcustom undo-ask-before-discard nil + "If non-nil ask about discarding undo info for the current command. +Normally, Emacs discards the undo info for the current command if +it exceeds `undo-outer-limit'. But if you set this option +non-nil, it asks in the echo area whether to discard the info. +If you answer no, there a slight risk that Emacs might crash, so +only do it if you really want to undo the command. + +This option is mainly intended for debugging. You have to be +careful if you use it for other purposes. Garbage collection is +inhibited while the question is asked, meaning that Emacs might +leak memory. So you should make sure that you do not wait +excessively long before answering the question." + :type 'boolean + :group 'undo + :version "22.1") + +(define-buffer-local *undo-extra-outer-limit* 'undo-outer-limit-truncate ;;nil + "If non-nil, an extra level of size that's ok in an undo item. +We don't ask the user about truncating the undo list until the +current item gets bigger than this amount. + +This variable only matters if `undo-ask-before-discard' is non-nil.") + +;;(make-variable-buffer-local 'undo-extra-outer-limit) + +;; When the first undo batch in an undo list is longer than +;; undo-outer-limit, this function gets called to warn the user that +;; the undo info for the current command was discarded. Garbage +;; collection is inhibited around the call, so it had better not do a +;; lot of consing. +;;(setq undo-outer-limit-function 'undo-outer-limit-truncate) +(defun undo-outer-limit-truncate (size) + (if undo-ask-before-discard + (when (or (null *undo-extra-outer-limit*) + (> size *undo-extra-outer-limit*)) + ;; Don't ask the question again unless it gets even bigger. + ;; This applies, in particular, if the user quits from the question. + ;; Such a quit quits out of GC, but something else will call GC + ;; again momentarily. It will call this function again, + ;; but we don't want to ask the question again. + (setf *undo-extra-outer-limit* (+ size 50000)) + (if (let (*use-dialog-box* *track-mouse* *executing-kbd-macro* ) + (yes-or-no-p (format nil "Buffer `~a' undo info is ~d bytes long; discard it? " + (buffer-name (current-buffer)) size))) + (progn (setf (buffer-undo-list (current-buffer)) nil) + (setf *undo-extra-outer-limit* nil) + t) + nil)) + (progn + (display-warning '(undo discard-info) + (concat + (format nil "Buffer `~a' undo info was ~d bytes long.~%" + (buffer-name (current-buffer)) size) + "The undo info was discarded because it exceeded \ +`undo-outer-limit'. + +This is normal if you executed a command that made a huge change +to the buffer. In that case, to prevent similar problems in the +future, set `undo-outer-limit' to a value that is large enough to +cover the maximum size of normal changes you expect a single +command to make, but not so large that it might exceed the +maximum memory allotted to Emacs. + +If you did not execute any such command, the situation is +probably due to a bug and you should report it. + +You can disable the popping up of this buffer by adding the entry +\(undo discard-info) to the user option `warning-suppress-types'. +") + :warning) + (setf (buffer-undo-list (current-buffer)) nil) + t))) + + +(defcommand kill-word ((arg) + :prefix) + "Kill characters forward until encountering the end of a word. +With argument, do this that many times." + (kill-region (point) (progn (forward-word arg) (point)))) + +(defcommand backward-kill-word ((arg) + :prefix) + "Kill characters backward until encountering the end of a word. +With argument, do this that many times." + (kill-word (- arg))) + +(defcommand backward-word ((n) :prefix) + "Move point forward ARG words (backward if ARG is negative). +Normally returns t. +If an edge of the buffer or a field boundary is reached, point is left there +and the function returns nil. Field boundaries are not noticed if +`inhibit-field-text-motion' is non-nil." + (forward-word (- n))) + +(defcommand forward-word ((n) :prefix) + "Move point forward ARG words (backward if ARG is negative). +Normally returns t. +If an edge of the buffer or a field boundary is reached, point is left there +and the function returns nil. Field boundaries are not noticed if +`inhibit-field-text-motion' is non-nil." + (labels ((isaword (c) + (find c +word-constituents+ :test #'char=))) + (let ((buffer (current-buffer))) + (cond ((> n 0) + (gap-move-to buffer (buffer-point-aref buffer)) + ;; do it n times + (loop for i from 0 below n + while (let (p1 p2) + ;; search forward for a word constituent + (setf p1 (position-if #'isaword (buffer-data buffer) + :start (buffer-point-aref buffer))) + ;; search forward for a non word constituent + (when p1 + (setf p2 (position-if (complement #'isaword) (buffer-data buffer) :start p1))) + (if p2 + (goto-char (buffer-aref-to-char buffer p2)) + (goto-char (point-max))) + p2))) + ((< n 0) + (setf n (- n)) + (gap-move-to buffer (buffer-point-aref buffer)) + ;; do it n times + (loop for i from 0 below n + for start = (buffer-gap-start buffer) then (buffer-point-aref buffer) + while (let (p1 p2) + ;; search backward for a word constituent + (setf p1 (position-if #'isaword (buffer-data buffer) + :from-end t + :end start)) + ;; search backward for a non word constituent + (when p1 + (setf p2 (position-if (complement #'isaword) (buffer-data buffer) :from-end t :end p1))) + (if p2 + (goto-char (1+ (buffer-aref-to-char buffer p2))) + (goto-char (point-min))) + p2))))))) + (provide :lice-0.1/simple) diff --git a/subr.lisp b/subr.lisp index ce22ac5..11cd8a7 100644 --- a/subr.lisp +++ b/subr.lisp @@ -1,82 +1,6 @@ ;;; subr.lice --- basic lisp subroutines for Emacs -(in-package :lice) - -(defun split-string (string &optional (separators " -")) - "Splits STRING into substrings where there are matches for SEPARATORS. -Each match for SEPARATORS is a splitting point. -The substrings between the splitting points are made into a list -which is returned. -***If SEPARATORS is absent, it defaults to \"[ \f\t\n\r\v]+\". - -If there is match for SEPARATORS at the beginning of STRING, we do not -include a null substring for that. Likewise, if there is a match -at the end of STRING, we don't include a null substring for that. - -Modifies the match data; use `save-match-data' if necessary." - ;; FIXME: This let is here because movitz doesn't 'lend optional' - (let ((seps separators)) - (labels ((sep (c) - (find c seps :test #'char=))) - (loop for i = (position-if (complement #'sep) string) - then (position-if (complement #'sep) string :start j) - while i - as j = (position-if #'sep string :start i) - collect (subseq string i j) - while j)))) - -(define-condition kbd-parse (lice-condition) - () (:documentation "Raised when a kbd string failed to parse.")) - -(defun parse-mods (mods end) - "MODS is a sequence of #\- pairs. Return a list suitable -for passing as the last argument to (apply #'make-key ...)" - (unless (evenp end) - (signal 'kbd-parse)) - (apply #'nconc (loop for i from 0 below end by 2 - if (char/= (char mods (1+ i)) #\-) - do (signal 'kbd-parse) - collect (case (char mods i) - (#\M (list :meta t)) - (#\A (list :alt t)) - (#\C (list :control t)) - (#\H (list :hyper t)) - (#\s (list :super t)) - (#\S (list :shift t)) - (t (signal 'kbd-parse)))))) - -(defun parse-char-name (string) - "Return the character whose name is STRING." - (or (cond - ((string= string "RET") #\Newline) - ((string= string "TAB") #\Tab)) - (name-char string) - (and (= (length string) 1) - (char string 0)))) - -(defun parse-key (string) - "Parse STRING and return a key structure." - ;; FIXME: we want to return NIL when we get a kbd-parse error - ;;(ignore-errors - (let* ((p (when (> (length string) 2) - (position #\- string :from-end t :end (- (length string) 1)))) - (mods (parse-mods string (if p (1+ p) 0))) - (ch (parse-char-name (subseq string (if p (1+ p) 0))))) - (and ch - (apply #'make-key :char ch mods)))) - -(defun parse-key-seq (keys) - "KEYS is a key sequence. Parse it and return the list of keys." - (mapcar 'parse-key (split-string keys))) - -(defun kbd (keys) - "Convert KEYS to the internal Emacs key representation. -KEYS should be a string constant in the format used for -saving keyboard macros ***(see `insert-kbd-macro')." - ;; XXX: define-key needs to be fixed to handle a list of keys - (first (parse-key-seq keys))) - +(in-package "LICE") ;;; Argument types @@ -213,6 +137,19 @@ See `walk-windows' for the meaning of MINIBUF and FRAME." (defun intern-soft (name &optional (package *package*)) (find-symbol name package)) +;;; reading from the buffer + +(defun read-from-buffer (&aux (buffer (current-buffer))) + "Read 1 sexp from the buffer at the current point, moving the point to the end of what was read" + (when (< (buffer-char-to-aref buffer (point buffer)) + (buffer-gap-start buffer)) + (gap-move-to-point buffer)) + (multiple-value-bind (obj pos) + (read-from-string (buffer-data buffer) t nil + :start (buffer-char-to-aref buffer (point buffer))) + (set-point (buffer-aref-to-char buffer pos)) + obj)) + (defcommand eval-region ((start end &optional print-flag (read-function 'read-from-string)) :region-beginning :region-end) "Execute the region as Lisp code. @@ -241,4 +178,17 @@ This function does not move point." (message "~s" last))) (return-from eval-region last))))) +(defun sit-for (seconds &optional nodisp) + "Perform redisplay, then wait for seconds seconds or until input is available. +seconds may be a floating-point value, meaning that you can wait for a +fraction of a second. + (Not all operating systems support waiting for a fraction of a second.) +Optional arg nodisp non-nil means don't redisplay, just wait for input. +Redisplay is preempted as always if input arrives, and does not happen +if input is available before it starts. +Value is t if waited the full time with no input arriving." + (declare (ignore seconds nodisp)) + ;; FIXME: actually sleep + (frame-render (selected-frame))) + (provide :lice-0.1/subr) diff --git a/syntax.lisp b/syntax.lisp index 70cdb3c..83b9a7b 100644 --- a/syntax.lisp +++ b/syntax.lisp @@ -1,6 +1,6 @@ ;;; Cheap syntax functions -(in-package :lice) +(in-package "LICE") (defparameter +syntax-classes+ '(:whitespace :punctuation :word-constituent :symbol-constituent :open :close :quote :string :math :escape @@ -119,6 +119,9 @@ It is a copy of the TABLE, which defaults to the standard syntax table." (make-instance 'syntax-table :hash hash :parent (syntax-table-parent table)))) +(defun syntax-table (&aux (buffer (current-buffer))) + (buffer-syntax-table buffer)) + (defun modify-syntax-entry (char class &key flags extra (table (syntax-table))) "Set syntax for character CHAR according to CLASS, FLAGS, and EXTRA." (check-type char character) @@ -144,7 +147,7 @@ the symbol `:WORD-CONSTITUENT' is returned." (defun syntax-after (pos &aux (buffer (current-buffer))) "Return the raw syntax of the char after POS. If POS is outside the buffer's accessible portion, return nil." - (unless (or (< pos (point-min)) (>= pos (point-max))) + (unless (or (< pos (begv buffer)) (>= pos (zv buffer))) (let* ((ch (buffer-char-after buffer pos)) (descr (and ch (gethash ch (syntax-table buffer))))) descr))) @@ -152,21 +155,15 @@ If POS is outside the buffer's accessible portion, return nil." ;; FIXME: having the flags as a list is memory intensive. How about a ;; bit vector or number and a function that converts between the two? -(defun buffer-syntax-table (buffer) - (major-mode-syntax-table (buffer-major-mode buffer))) - -(defun syntax-table (&aux (buffer (current-buffer))) - (buffer-syntax-table buffer)) +(defun (setf syntax-table) (value &aux (buffer (current-buffer))) + "Select a new syntax table for the current buffer. One argument, a syntax table." + (check-type value syntax-table) + (setf (buffer-syntax-table buffer) value)) -;; (defun (setf syntax-table) (value &aux (buffer (current-buffer))) -;; "Select a new syntax table for the current buffer. One argument, a syntax table." -;; (check-type value syntax-table) -;; (setf (buffer-syntax-table buffer) value)) - -;; ;; The above looks a bit weird so lets also have a set function. -;; (defun set-syntax-table (value) -;; "Select a new syntax table for the current buffer. One argument, a syntax table." -;; (setf (syntax-table) value)) +(depricate set-syntax-table (setf syntax-table)) +(defun set-syntax-table (value) + "Select a new syntax table for the current buffer. One argument, a syntax table." + (setf (syntax-table) value)) (defun &syntax-with-flags (ch table &optional (default :whitespace)) (or (gethash ch (syntax-table-hash table)) @@ -324,69 +321,6 @@ beginning." (dec-both from from-aref buffer)) (incf count)) from)) - -(defcommand forward-word ((n) :prefix) - "Move point forward ARG words (backward if ARG is negative). -Normally returns t. -If an edge of the buffer or a field boundary is reached, point is left there -and the function returns nil. Field boundaries are not noticed if -`inhibit-field-text-motion' is non-nil." - (labels ((isaword (c) - (find c +word-constituents+ :test #'char=))) - (let ((buffer (current-buffer))) - (cond ((> n 0) - (gap-move-to buffer (buffer-point-aref buffer)) - ;; do it n times - (loop for i from 0 below n - while (let (p1 p2) - ;; search forward for a word constituent - (setf p1 (position-if #'isaword (buffer-data buffer) - :start (buffer-point-aref buffer))) - ;; search forward for a non word constituent - (when p1 - (setf p2 (position-if (complement #'isaword) (buffer-data buffer) :start p1))) - (if p2 - (goto-char (buffer-aref-to-char buffer p2)) - (goto-char (point-max))) - p2))) - ((< n 0) - (setf n (- n)) - (gap-move-to buffer (buffer-point-aref buffer)) - ;; do it n times - (loop for i from 0 below n - for start = (buffer-gap-start buffer) then (buffer-point-aref buffer) - while (let (p1 p2) - ;; search backward for a word constituent - (setf p1 (position-if #'isaword (buffer-data buffer) - :from-end t - :end start)) - ;; search backward for a non word constituent - (when p1 - (setf p2 (position-if (complement #'isaword) (buffer-data buffer) :from-end t :end p1))) - (if p2 - (goto-char (1+ (buffer-aref-to-char buffer p2))) - (goto-char (point-min))) - p2))))))) - -(defcommand backward-word ((n) :prefix) - "Move point forward ARG words (backward if ARG is negative). -Normally returns t. -If an edge of the buffer or a field boundary is reached, point is left there -and the function returns nil. Field boundaries are not noticed if -`inhibit-field-text-motion' is non-nil." - (forward-word (- n))) - -(defcommand kill-word ((arg) - :prefix) - "Kill characters forward until encountering the end of a word. -With argument, do this that many times." - (kill-region (point) (progn (forward-word arg) (point)))) - -(defcommand backward-kill-word ((arg) - :prefix) - "Kill characters backward until encountering the end of a word. -With argument, do this that many times." - (kill-word (- arg))) (defvar *parse-sexp-ignore-comments* t "Non-nil means `forward-sexp', etc., should treat comments as whitespace.") @@ -421,6 +355,20 @@ or after. On return global syntax data is good for lookup at CHAR-POS." (setf quoted (not quoted)))) quoted)) +(defstruct parse-state + depth min-depth + this-level-start + prev-level-start + location + level-starts + quoted + in-comment + comment-style + comment-string-start + in-string + start-value + start-value-aref) + (defun find-defun-start (pos pos-aref buffer table) "Return a defun-start position before POS and not too far before. It should be the last one before POS, or nearly the last. @@ -459,7 +407,7 @@ update the global data." :start-pos pos))) ;; FIXME: doesn't handle ^. Maybe if :not is the first symbol in the list? -(defun skip-syntax-forward (syntax-list &optional (lim (point-max))) +(defun skip-syntax-forward (syntax-list &optional (lim (zv))) "Move point forward across chars in specified syntax classes. SYNTAX-LIST is a string of syntax code characters. Stop before a char whose syntax is not in SYNTAX-LIST, or at position LIM. @@ -468,7 +416,7 @@ This function returns the distance traveled, either zero or positive." (check-type lim integer) (let* ((buffer (current-buffer)) (table (syntax-table)) - (pos (point)) + (pos (pt)) (start pos) (pos-aref (buffer-char-to-aref buffer pos)) ch syntax) @@ -507,7 +455,7 @@ This function returns the distance traveled, either zero or positive." negate ranges chars - (start-point (point))) + (start-point (pt))) ;; don't allow scan outside bounds of buffer. (setf lim (min (max lim (begv)) (zv))) @@ -548,7 +496,7 @@ This function returns the distance traveled, either zero or positive." (push c chars))))) ;; scan (let* ((buffer (current-buffer)) - (pos (point buffer)) + (pos (pt buffer)) (pos-aref (buffer-char-to-aref buffer pos))) (catch :done (if forwardp @@ -581,234 +529,6 @@ This function returns the distance traveled, either zero or positive." "Move point forward, stopping before a char that is not a space or tab." (skip-chars-forward (coerce '(#\Space #\Tab) 'string) lim)) -(defun &back-comment (from from-aref stop comment-nested comment-style buffer table) - "Checks whether charpos FROM is at the end of a comment. -FROM_BYTE is the bytepos corresponding to FROM. -Do not move back before STOP. - -Return a positive value if we find a comment ending at FROM/FROM_BYTE; -return -1 otherwise. - -If successful, return the charpos of the comment's beginning, and the aref pos. - -**Global syntax data remains valid for backward search starting at -**the returned value (or at FROM, if the search was not successful)." - ;; Look back, counting the parity of string-quotes, - ;; and recording the comment-starters seen. - ;; When we reach a safe place, assume that's not in a string; - ;; then step the main scan to the earliest comment-starter seen - ;; an even number of string quotes away from the safe place. - ;; - ;; OFROM[I] is position of the earliest comment-starter seen - ;; which is I+2X quotes from the comment-end. - ;; PARITY is current parity of quotes from the comment end. - (let ((string-style :none) - (string-lossage nil) - ;; Not a real lossage: indicates that we have passed a matching comment - ;; starter plus a non-matching comment-ender, meaning that any matching - ;; comment-starter we might see later could be a false positive (hidden - ;; inside another comment). - ;; Test case: { a (* b } c (* d *) - (comment-lossage nil) - (comment-end from) - (comment-end-aref from-aref) - (comment-start-pos 0) - comment-start-aref - ;; Place where the containing defun starts, - ;; or nil if we didn't come across it yet. - defun-start - defun-start-aref - code - (nesting 1) ; current comment nesting - ch - (syntax nil)) - (handler-case - (progn - ;; FIXME: A }} comment-ender style leads to incorrect behavior - ;; in the case of {{ c }}} because we ignore the last two chars which are - ;; assumed to be comment-enders although they aren't. - ;; - ;; At beginning of range to scan, we're outside of strings; - ;; that determines quote parity to the comment-end. - (while (/= from stop) - (catch :continue - (let (temp-aref prev-syntax com2start com2end) - (dec-both from from-aref buffer) - (setf prev-syntax syntax - ch (buffer-fetch-char from-aref buffer) - syntax (&syntax-with-flags ch table) - code (&syntax ch table) - ;; Check for 2-char comment markers. - com2start (and (&syntax-flags-comment-start-first syntax) - (&syntax-flags-comment-start-second prev-syntax) - (eq comment-style (&syntax-flags-comment-style prev-syntax)) - (eq (or (&syntax-flags-comment-nested prev-syntax) - (&syntax-flags-comment-nested syntax)) - comment-nested)) - com2end (and (&syntax-flags-comment-end-first syntax) - (&syntax-flags-comment-end-second prev-syntax))) - ;; Nasty cases with overlapping 2-char comment markers: - ;; - snmp-mode: -- c -- foo -- c -- - ;; --- c -- - ;; ------ c -- - ;; - c-mode: *||* - ;; |* *|* *| - ;; |*| |* |*| - ;; /// */ - - ;; If a 2-char comment sequence partly overlaps with - ;; another, we don't try to be clever. - (when (and (> from stop) - (or com2end com2start)) - (let ((next from) - (next-aref from-aref) - next-c - next-syntax) - (dec-both next next-aref buffer) - (setf next-c (buffer-fetch-char next-aref buffer) - next-syntax (&syntax-with-flags next-c table)) - (when (or (and (or com2start comment-nested) - (&syntax-flags-comment-end-second syntax) - (&syntax-flags-comment-end-first next-syntax)) - (and (or com2end comment-nested) - (&syntax-flags-comment-start-second syntax) - (eq comment-style (&syntax-flags-comment-style syntax)) - (&syntax-flags-comment-start-first next-syntax))) - (signal 'syntax-lossage)))) - - (when (and com2start - (= comment-start-pos 0)) - ;; We're looking at a comment starter. But it might be a comment - ;; ender as well (see snmp-mode). The first time we see one, we - ;; need to consider it as a comment starter, - ;; and the subsequent times as a comment ender. - (setf com2end 0)) - - ;; Turn a 2-char comment sequences into the appropriate syntax. - (cond (com2end - (setf code :end-comment)) - (com2start - (setf code :comment)) - ;; Ignore comment starters of a different style. - ((and (eq code :comment) - (or (not (eq comment-style (&syntax-flags-comment-style syntax))) - (not (eq comment-nested (&syntax-flags-comment-nested syntax))))) - (throw :continue nil))) - - ;; Ignore escaped characters, except comment-enders. - (when (and (not (eq code :end-comment)) - (&char-quoted from from-aref buffer table)) - (throw :continue nil)) - - (case code - ((:string-fence :comment-fence :string) - (when (find code '(:string-fence :comment-fence)) - (setf ch (if (eq code :string-fence) - :string-style - :comment-style))) - ;; Track parity of quotes. - (cond ((eq string-style :none) - ;; Entering a string. - (setf string-style ch)) - ((eq string-style ch) - ;; leaving the string - (setf string-style :none)) - (t - ;; If we have two kinds of string delimiters. - ;; There's no way to grok this scanning backwards. - (setf string-lossage t)))) - (:comment - ;; We've already checked that it is the relevant comstyle. - (when (or (eq string-style :none) - comment-lossage - string-lossage) - ;; There are odd string quotes involved, so let's be careful. - ;; Test case in Pascal: " { " a { " } */ - (signal 'syntax-lossage)) - (if (not comment-nested) - ;; Record best comment-starter so far. - (setf comment-start-pos from - comment-start-aref from-aref) - (progn - (decf nesting) - (when (<= nesting) - ;; nested comments have to be balanced, so we don't need to - ;; keep looking for earlier ones. We use here the same (slightly - ;; incorrect) reasoning as below: since it is followed by uniform - ;; paired string quotes, this comment-start has to be outside of - ;; strings, else the comment-end itself would be inside a string. - (signal 'syntax-done))))) - (:end-comment - (cond ((and (eq comment-style (&syntax-flags-comment-style syntax)) - (or (and com2end - (&syntax-flags-comment-nested prev-syntax)) - (eq comment-nested (&syntax-flags-comment-nested syntax)))) - ;; This is the same style of comment ender as ours. - (if comment-nested - (incf nesting) - ;; Anything before that can't count because it would match - ;; this comment-ender rather than ours. - (setf from stop))) - ((or (/= comment-start-pos 0) - (char/= ch #\Newline)) - ;; We're mixing comment styles here, so we'd better be careful. - ;; The (comstart_pos != 0 || c != '\n') check is not quite correct - ;; (we should just always set comment_lossage), but removing it - ;; would imply that any multiline comment in C would go through - ;; lossage, which seems overkill. - ;; The failure should only happen in the rare cases such as - ;; { (* } *) - (setf comment-lossage t)))) - (:open - ;; Assume a defun-start point is outside of strings. - (when (and *open-paren-in-column-0-is-defun-start* - (or (= from stop) - (progn - (setf temp-aref (aref-minus-1 from-aref buffer)) - (char= (buffer-fetch-char temp-aref buffer) #\Newline)))) - (setf defun-start from - defun-start-aref from-aref - ;; Break out of the loop. - from stop))))))) - - (if (= comment-start-pos 0) - (setf from comment-end - from-aref comment-end-aref) - ;; If comstart_pos is set and we get here (ie. didn't jump to `lossage' - ;; or `done'), then we've found the beginning of the non-nested comment. - (setf from comment-start-pos - from-aref comment-start-aref))) - (syntax-lossage () - ;; We had two kinds of string delimiters mixed up - ;; together. Decode this going forwards. - ;; Scan fwd from a known safe place (beginning-of-defun) - ;; to the one in question; this records where we - ;; last passed a comment starter. - ;; If we did not already find the defun start, find it now. - (when (= defun-start 0) - (let ((ret (find-defun-start comment-end comment-end-aref buffer table))) - (setf defun-start (parse-state-start-value ret) - defun-start-aref (parse-state-start-value-aref ret)))) - (loop do - (let ((state (scan-sexps-forward defun-start defun-start-aref - comment-end -10000 0 nil 0 buffer table))) - (setf defun-start comment-end) - (if (and (eq (parse-state-in-comment state) comment-nested) - (eq (parse-state-comment-style state) comment-style)) - (setf from (parse-state-comment-string-start state)) - (progn - (setf from comment-end) - (when (parse-state-in-comment state) ; XXX - ;; If comment_end is inside some other comment, maybe ours - ;; is nested, so we need to try again from within the - ;; surrounding comment. Example: { a (* " *) - (setf defun-start (+ (parse-state-comment-string-start state) 2) - defun-start-aref (buffer-char-to-aref buffer defun-start)))))) - while (< defun-start comment-end)) - (setf from-aref (buffer-char-to-aref buffer from)))) - (values (if (= from comment-end) -1 from) - from-aref))) - (defun &forward-comment (from from-aref stop nesting style prev-syntax buffer table) "Jump over a comment, assuming we are at the beginning of one. FROM is the current position. @@ -921,644 +641,858 @@ remains valid for forward search starting at the returned position." (forward) (do-comment)))) (values t from from-aref)))) - -(defun prev-char-comment-end-first (pos pos-aref buffer table) - "Return the SYNTAX_COMEND_FIRST of the character before POS, POS_BYTE." - (dec-both pos pos-aref buffer) - (&syntax-comment-end-first (buffer-fetch-char pos-aref buffer) - table)) -(defun &scan-lists (from count depth sexpflag &aux (buffer (current-buffer))) - "This is from the emacs function" - ;; the big TODO here is to use the CL readtable - (labels ((lose (last-good from) - (signal 'unbalanced-parenthesis :last-good last-good :from from))) - (let ((stop (if (> count 0) (zv buffer) (begv buffer))) - (from-aref (buffer-char-to-aref buffer from)) - (min-depth (min 0 depth)) - (table (syntax-table)) - (last-good from) - quoted - math-exit - comment-start-first - code - ch ch1 - temp-code - temp-pos - comment-nested - comment-style - found - prefix) - ;; normalize FROM - (setf from (max (min (zv buffer) from) - (begv buffer))) - (while (> count 0) - ;; the code needs to be able to jump out of the mess it got - ;; in. - (handler-case - (progn - (while (< from stop) - (catch :continue - (setf ch (buffer-fetch-char from-aref buffer) - code (&syntax ch table) - comment-start-first (&syntax-comment-start-first ch table) - comment-nested (&syntax-comment-nested ch table) - comment-style (&syntax-comment-style ch table) - prefix (&syntax-prefix ch table)) - (when (= depth min-depth) - (setf last-good from)) - (inc-both from from-aref buffer) - (when (and (< from stop) comment-start-first - (progn (setf ch (buffer-fetch-char from-aref buffer)) - (&syntax-comment-start-second ch table)) - *parse-sexp-ignore-comments*) - ;; we have encountered a comment start sequence and - ;; we are ignoring all text inside comments. We - ;; must record the comment style this sequence - ;; begins so that later, only a comment end of the - ;; same style actually ends the comment section - (setf code :comment - ch1 (buffer-fetch-char from-aref buffer) - comment-style (&syntax-comment-style ch1 table) - comment-nested (or comment-nested - (&syntax-comment-nested ch1 table))) - (inc-both from from-aref buffer)) - - (when prefix - (throw :continue nil)) +(defstruct syntax-level + last prev) - (when (or (eq code :escape) - (eq code :character-quote)) - (when (= from stop) (lose last-good from)) - (inc-both from from-aref buffer) - ;; treat following character as a word constituent - (setf code :word-constituent)) +;; this function cries out for continuations. you almost have to look +;; at the C code to understand what's going on here, i bet. Hell, I +;; don't even understand it. +(defun scan-sexps-forward (from from-aref end target-depth stop-before old-state comment-stop buffer table) + "Parse forward from FROM / FROM_BYTE to END, +assuming that FROM has state OLDSTATE (nil means FROM is start of function), +and return a description of the state of the parse at END. +If STOPBEFORE is nonzero, stop at the start of an atom. +If COMMENTSTOP is 1, stop at the start of a comment. +If COMMENTSTOP is -1, stop at the start or end of a comment, +after the beginning of a string, or after the end of a string." + ;;(message "scan-sexps-forward ~@{~a ~}" from from-aref end target-depth stop-before old-state comment-stop buffer table) + (let ((state (make-parse-state)) + (prev-from from) + (prev-from-aref from-aref) + prev-from-syntax + (boundary-stop (null comment-stop)) + no-fence + c1 + code + comment-nested + depth + min-depth + temp + start-quoted + levels) + (labels ((inc-from () + (setf prev-from from + prev-from-aref from-aref + temp (buffer-fetch-char prev-from-aref buffer) + prev-from-syntax (&syntax-with-flags temp table)) + (inc-both from from-aref buffer)) + (cur-level () + "Return the current level struct" + (car levels)) + (do-start-in-comment () + ;; The (from == BEGV) test was to enter the loop in the middle so + ;; that we find a 2-char comment ender even if we start in the + ;; middle of it. We don't want to do that if we're just at the + ;; beginning of the comment (think of (*) ... (*)). + (multiple-value-bind (found out-char out-aref in-comment) + (&forward-comment from from-aref end + (parse-state-in-comment state) + (parse-state-comment-style state) + (if (or (eq from (begv buffer)) + (< from (+ (parse-state-comment-string-start state) 3))) + nil prev-from-syntax) + buffer table) + (setf from out-char + from-aref out-aref + (parse-state-in-comment state) in-comment) + ;; Beware! prev_from and friends are invalid now. + ;; Luckily, the `done' doesn't use them and the INC_FROM + ;; sets them to a sane value without looking at them. + (unless found (throw :end :done)) + (inc-from) + (setf (parse-state-in-comment state) nil + (parse-state-comment-style state) nil) ; reset the comment style + (when boundary-stop (throw :end :done)))) + (do-sym-done () + ;;(message "do-sym-done ~s" (parse-state-level-starts state)) + (setf (syntax-level-prev (cur-level)) (syntax-level-last (cur-level)))) + (do-sym-started () + ;; (message "do-sym-started") + (while (< from end) + (case (&syntax (buffer-fetch-char from-aref buffer) table) + ((:escape :character-quote) + (inc-from) + (when (= from end) + (throw :end :end-quoted))) + ((:word-constituent :symbol-constituent :quote)) + (t + (do-sym-done) + (return nil))) + (inc-from))) + (do-start-quoted () + (when (= from end) (throw :end :end-quoted)) + (inc-from) + (do-sym-started)) + (do-in-string-loop () + (loop + (let (c) + (when (>= from end) (throw :end :done)) + (setf c (buffer-fetch-char from-aref buffer) + temp (&syntax c table)) + ;; Check TEMP here so that if the char has + ;; a syntax-table property which says it is NOT + ;; a string character, it does not end the string. + (when (and no-fence + (equal c (parse-state-in-string state)) + (eq temp :string)) + (return nil)) + (case temp + (:string-fence + (unless no-fence (return nil))) + ((:character-quote :escape) + (inc-from) + (when (>= from end) (throw :end :end-quoted)))) + (inc-from)))) + (do-string-end () + ;;(message "do-string-end ~s" (parse-state-level-starts state)) + (setf (parse-state-in-string state) nil + (syntax-level-prev (cur-level)) (syntax-level-last (cur-level))) + (inc-from) + (when boundary-stop (throw :end :done))) + (do-start-in-string () + (setf no-fence (not (eq (parse-state-in-string state) :st-string-style))) + (do-in-string-loop) + (do-string-end)) + (do-start-quoted-in-string () + (when (>= from end) (throw :end :end-quoted)) + (inc-from) + (do-in-string-loop))) - (case code - ((:word-constituent :symbol-constituent) - (unless (or (not (zerop depth)) - (not sexpflag)) - (let (temp) - (while (< from stop) - (setf ch (buffer-fetch-char from-aref buffer) - temp (&syntax ch table)) - (case temp - ((:escape :character-quote) - (inc-both from from-aref buffer) - (when (= from stop) (lose last-good from))) - ((:word-constituent :symbol-constituent :quote)) - (t - (signal 'syntax-done))) - (inc-both from from-aref buffer))) - (signal 'syntax-done))) - ((:comment-fence :comment) - (when (eq code :comment-fence) - (setf comment-style :st-comment-style)) - (multiple-value-setq (found from from-aref) (&forward-comment from from-aref stop comment-nested comment-style nil buffer table)) - (unless found - (when (zerop depth) (signal 'syntax-done)) - (lose last-good from)) - (inc-both from from-aref buffer)) - (:math - (when sexpflag - (when (and (/= from stop) - (char= ch (buffer-fetch-char from-aref buffer))) - (inc-both from from-aref buffer)) - (if math-exit - (progn - (setf math-exit nil) - (decf depth) - (when (zerop depth) (signal 'syntax-done)) - (when (< depth min-depth) - (signal 'expression-ends-prematurely))) ; XXX - (progn - (setf math-exit t) - (incf depth) - (when (zerop depth) (signal 'syntax-done)))))) - (:open - (incf depth) - (when (zerop depth) (signal 'syntax-done))) - (:close - (decf depth) - (when (zerop depth) (signal 'syntax-done)) - (when (< depth min-depth) - (signal 'expression-ends-prematurely))) - ((:string :string-fence) - (let* ((tmp-pos (aref-minus-1 from-aref buffer)) - (string-term (buffer-fetch-char tmp-pos buffer)) - temp) - (loop - (when (>= from stop) (lose last-good from)) - (setf ch (buffer-fetch-char from-aref buffer)) - (when (if (eq code :string) - (and (char= ch string-term) - (eq (&syntax ch table) :string)) - (eq (&syntax ch table) :string-fence)) - (return nil)) - (setf temp (&syntax ch table)) - (case temp - ((:character-quote :escape) - (inc-both from from-aref buffer))) - (inc-both from from-aref buffer)) - (inc-both from from-aref buffer) - (when (and (zerop depth) - sexpflag) - (signal 'syntax-done)))) - (t - ;; Ignore whitespace, punctuation, quote, endcomment. - )))) - (unless (zerop depth) (lose last-good from)) - (return-from &scan-lists nil)) - (syntax-done () - (decf count)))) + (when (/= from (begv buffer)) + (dec-both prev-from prev-from-aref buffer)) - (while (< count 0) - (handler-case - (progn - (while (> from stop) - (catch :continue - (dec-both from from-aref buffer) - (setf ch (buffer-fetch-char from-aref buffer) - code (&syntax ch table)) - (when (= depth min-depth) - (setf last-good from)) - (setf comment-style nil - comment-nested (&syntax-comment-nested ch table)) - (when (eq code :end-comment) - (setf comment-style (&syntax-comment-style ch table))) - (when (and (> from stop) - (&syntax-comment-end-second ch table) - (prev-char-comment-end-first from from-aref buffer table) - *parse-sexp-ignore-comments*) - ;; We must record the comment style - ;; encountered so that later, we can match - ;; only the proper comment begin sequence of - ;; the same style. - (dec-both from from-aref buffer) - (setf code :end-comment - ch1 (buffer-fetch-char from-aref buffer) - comment-nested (or comment-nested - (&syntax-comment-nested ch1 table)))) - ;; Quoting turns anything except a comment-ender - ;; into a word character. Note that this cannot - ;; be true if we decremented FROM in the - ;; if-statement above. - (cond - ((and (not (eq code :end-comment)) - (&char-quoted from from-aref buffer table)) - (dec-both from from-aref buffer) - (setf code :word)) - ((&syntax-prefix ch table) - ;; loop around again. I think this is nasty but fuckit. - (throw :continue nil))) - (case code - ((:word-constituent :symbol-constituent :escape :character-quote) - (unless (or (not (zerop depth)) - (not sexpflag)) - ;; This word counts as a sexp; count - ;; object finished after passing it. - (while (> from stop) - (setf temp-pos from-aref) - (decf temp-pos) - (setf ch1 (buffer-fetch-char temp-pos buffer) - temp-code (&syntax ch1 table)) - ;; Don't allow comment-end to be quoted. - (when (eq temp-code :end-comment) - (signal 'syntax-done)) - (setf quoted (&char-quoted (1- from) temp-pos buffer table)) - (when quoted - (dec-both from from-aref buffer) - (setf temp-pos (aref-minus-1 temp-pos buffer))) - (setf ch1 (buffer-fetch-char temp-pos buffer) - temp-code (&syntax ch1 table)) - (when (not (or quoted - (eq temp-code :word-constituent) - (eq temp-code :symbol-constituent) - (eq temp-code :quote))) - (signal 'syntax-done)) - (dec-both from from-aref buffer)) - (signal 'syntax-done))) - (:math - (when sexpflag - (setf temp-pos (aref-minus-1 from-aref buffer)) - (when (and (/= from stop) - (char= ch (buffer-fetch-char temp-pos buffer))) - (dec-both from from-aref buffer)) - (if math-exit - (progn - (setf math-exit nil) - (decf depth) - (when (zerop depth) (signal 'syntax-done)) - (when (< depth min-depth) - (signal 'expression-ends-prematurely))) - (progn - (setf math-exit t) - (incf depth) - (when (zerop depth) (signal 'syntax-done)))))) - (:close - (incf depth) - (when (zerop depth) (signal 'syntax-done))) - (:open - (decf depth) - (when (zerop depth) (signal 'syntax-done)) - (when (< depth min-depth) - (signal 'expression-ends-prematurely))) - (:end-comment - (when *parse-sexp-ignore-comments* - (multiple-value-bind (found char-pos aref-pos) - (&back-comment from from-aref stop comment-nested comment-style buffer table) - (when (eq found :not-comment-end) - (setf from char-pos - from-aref aref-pos))))) - ((:comment-fence :string-fence) - (loop - (when (= from stop) (lose last-good from)) - (dec-both from from-aref buffer) - (when (and (not (&char-quoted from from-aref buffer table)) - (progn - (setf ch (buffer-fetch-char from-aref buffer)) - (eq (&syntax ch table) code))) - (return nil))) - (when (and (eq code :string-fence) - (zerop depth) - sexpflag) - (signal 'syntax-done))) - (:string - (let ((string-term (buffer-fetch-char from-aref buffer))) - (loop - (when (= from stop) (lose last-good from)) - (dec-both from from-aref buffer) - (when (and (not (&char-quoted from from-aref buffer table)) - (progn - (setf ch (buffer-fetch-char from-aref buffer)) - (char= string-term ch)) - (eq (&syntax ch table) :string)) - (return nil))) - (when (and (zerop depth) - sexpflag) - (signal 'syntax-done)))) - (t - ;; Ignore whitespace, punctuation, quote, endcomment. - )))) - (when (not (zerop depth)) (lose last-good from)) - (return-from &scan-lists nil)) - (syntax-done () - (incf count)))) - from))) + (if old-state + (progn + (setf state old-state + start-quoted (parse-state-quoted state) + depth (or (parse-state-depth state) 0) + start-quoted (parse-state-quoted state)) + (dolist (i (parse-state-level-starts state)) + (push (make-syntax-level :last i) levels)) + ;; make sure we have at least one in the list + (unless levels + (push (make-syntax-level) levels))) + (setf depth 0 + state (make-parse-state) + levels (list (make-syntax-level)))) -(defun scan-lists (from count depth) - "Scan from character number FROM by COUNT lists. -Returns the character number of the position thus found. + ;;(message "top ~s" (parse-state-level-starts state)) -If DEPTH is nonzero, paren depth begins counting from that value, -only places where the depth in parentheses becomes zero -are candidates for stopping; COUNT such places are counted. -Thus, a positive value for DEPTH means go out levels. + (setf (parse-state-quoted state) nil + min-depth depth) -Comments are ignored if `*parse-sexp-ignore-comments*' is non-nil. + (setf temp (buffer-fetch-char prev-from-aref buffer) + prev-from-syntax (&syntax-with-flags temp table)) -If the beginning or end of (the accessible part of) the buffer is reached -and the depth is wrong, an error is signaled. -If the depth is right but the count is not used up, nil is returned." - (check-type from number) - (check-type count number) - (check-type depth number) - (&scan-lists from count depth nil)) + ;; "Enter" the loop at a place appropriate for initial state. In + ;; the C code this is a bunch of goto's. Here we call the + ;; appropriate function that sync's us so we're ready to enter + ;; the loop. + (cond ((parse-state-in-comment state) + (do-start-quoted)) + ((parse-state-in-string state) + (setf no-fence (not (eq (parse-state-in-string state) :st-string-style))) + (if start-quoted + (do-start-quoted-in-string) + (do-start-in-string))) + (start-quoted + (do-start-quoted))) + ;; (message "sane here") + (case + (catch :end + (while (< from end) + (catch :continue + (inc-from) + (setf code (&syntax-flags-syntax prev-from-syntax)) + ;; (message "here the code is ~s" code) + (cond ((and (< from end) + (&syntax-flags-comment-start-first prev-from-syntax) + (progn + (setf c1 (buffer-fetch-char from-aref buffer)) + (&syntax-comment-start-second c1 table))) + ;; (message "here 1") + ;; Record the comment style we have entered so that only + ;; the comment-end sequence of the same style actually + ;; terminates the comment section. + (setf (parse-state-comment-style state) (&syntax-comment-style c1 table) + comment-nested (&syntax-flags-comment-nested prev-from-syntax) + comment-nested (or comment-nested + (&syntax-comment-nested c1 table)) + (parse-state-in-comment state) comment-nested + (parse-state-comment-string-start state) prev-from) + (inc-from) + (setf code :comment)) + ((eq code :comment-fence) + ;; (message "here 2") + ;; Record the comment style we have entered so that only + ;; the comment-end sequence of the same style actually + ;; terminates the comment section. + (setf (parse-state-comment-style state) :st-comment-style + (parse-state-in-comment state) -1 ; XXX + (parse-state-comment-string-start state) prev-from + code :comment)) + ((eq code :comment) + ;; (message "here 3") + (setf (parse-state-comment-style state) (&syntax-flags-comment-style prev-from-syntax) + (parse-state-in-comment state) (&syntax-flags-comment-nested prev-from-syntax) + (parse-state-comment-string-start state) prev-from))) -(defun scan-sexps (from count) - "Scan from character number FROM by COUNT balanced expressions. -If COUNT is negative, scan backwards. -Returns the character number of the position thus found. + (when (&syntax-flags-prefix prev-from-syntax) + (throw :continue nil)) -Comments are ignored if `parse-sexp-ignore-comments' is non-nil. + ;;(message "code: ~s" code) + (case code + ((:escape :character-quote) + ;; this arg means stop at sexp start + (when stop-before (throw :end :stop)) + ;;(message ":escae ~s" (parse-state-level-starts state)) + (setf (syntax-level-last (cur-level)) prev-from) + (do-start-quoted)) -If the beginning or end of (the accessible part of) the buffer is reached -in the middle of a parenthetical grouping, an error is signaled. -If the beginning or end is reached between groupings -but before count is used up, nil is returned." - (check-type from number) - (check-type count number) - (&scan-lists from count 0 t)) + ((:word-constituent :symbol-constituent) + (when stop-before (throw :end :stop)) + ;;(message ":word-con ~s" (parse-state-level-starts state)) + (setf (syntax-level-last (cur-level)) prev-from) + (do-sym-started)) -(defun backward-prefix-chars (&aux (buffer (current-buffer)) (table (syntax-table))) - "Move point backward over any number of chars with prefix syntax. -This includes chars with \"quote\" or \"prefix\" syntax (' or p)." - (let* ((beg (begv buffer)) - (pos (point buffer)) - (pos-aref (buffer-char-to-aref buffer pos)) - (opoint (point buffer)) - (opoint-aref (buffer-char-to-aref buffer pos)) - c) - (when (<= pos beg) - ;; SET_PT_BOTH (opoint, opoint_byte); - (return-from backward-prefix-chars nil)) + ((:comment-fence :comment) + (when (or comment-stop + boundary-stop) + (throw :end :done)) + (do-start-in-comment)) + + (:open + (when stop-before (throw :end :stop)) + (incf depth) + ;;(message ":open ~s" (parse-state-level-starts state)) + (setf (syntax-level-last (cur-level)) prev-from) + ;; (message ":open ~a" (parse-state-level-starts state)) + (push (make-syntax-level) levels) + ;; (when (> (length level-list) 100) ; XXX hardcoded + ;; (error "nesting too deep for parser")) + (when (= target-depth depth) (throw :end :done))) + + (:close + (decf depth) + (when (< depth min-depth) + (setf min-depth depth)) + (unless (= (length levels) 1) + ;;(message "XXX: popping when levels is 1!") + (pop levels)) + (setf (syntax-level-prev (cur-level)) (syntax-level-last (cur-level))) + (when (= target-depth depth) + (throw :end :done))) + + ((:string :string-fence) + (setf (parse-state-comment-string-start state) (1- from)) + (when stop-before + (throw :end :stop)) + (setf (syntax-level-last (cur-level)) prev-from) + (setf (parse-state-in-string state) (if (eq code :string) + (buffer-fetch-char prev-from-aref buffer) + :st-string-style)) + (when boundary-stop + (throw :end :done)) + (do-start-in-string)) + + (:math + ;; FIXME: We should do something with it. + ) + (t + ;; Ignore whitespace, punctuation, quote, endcomment. + )))) + :done) + (:stop + ;; Here if stopping before start of sexp. + ;; We have just fetched the char that starts it + ;; but return the position before it. + (setf from prev-from)) + (:end-quoted + (setf (parse-state-quoted state) t))) + + ;;(message ":end ~s" (parse-state-level-starts state)) + ;; done + (setf (parse-state-depth state) depth + (parse-state-min-depth state) min-depth + (parse-state-this-level-start state) (syntax-level-prev (cur-level)) + (parse-state-prev-level-start state) (if (<= (length levels) 1) + nil (syntax-level-last (second levels))) + (parse-state-location state) from + (parse-state-level-starts state) (mapcar 'syntax-level-last (cdr levels))) + state))) + +(defun &back-comment (from from-aref stop comment-nested comment-style buffer table) + "Checks whether charpos FROM is at the end of a comment. +FROM_BYTE is the bytepos corresponding to FROM. +Do not move back before STOP. + +Return a positive value if we find a comment ending at FROM/FROM_BYTE; +return -1 otherwise. + +If successful, return the charpos of the comment's beginning, and the aref pos. + +**Global syntax data remains valid for backward search starting at +**the returned value (or at FROM, if the search was not successful)." + ;; Look back, counting the parity of string-quotes, + ;; and recording the comment-starters seen. + ;; When we reach a safe place, assume that's not in a string; + ;; then step the main scan to the earliest comment-starter seen + ;; an even number of string quotes away from the safe place. + ;; + ;; OFROM[I] is position of the earliest comment-starter seen + ;; which is I+2X quotes from the comment-end. + ;; PARITY is current parity of quotes from the comment end. + (let ((string-style :none) + (string-lossage nil) + ;; Not a real lossage: indicates that we have passed a matching comment + ;; starter plus a non-matching comment-ender, meaning that any matching + ;; comment-starter we might see later could be a false positive (hidden + ;; inside another comment). + ;; Test case: { a (* b } c (* d *) + (comment-lossage nil) + (comment-end from) + (comment-end-aref from-aref) + (comment-start-pos 0) + comment-start-aref + ;; Place where the containing defun starts, + ;; or nil if we didn't come across it yet. + defun-start + defun-start-aref + code + (nesting 1) ; current comment nesting + ch + (syntax nil)) + (handler-case + (progn + ;; FIXME: A }} comment-ender style leads to incorrect behavior + ;; in the case of {{ c }}} because we ignore the last two chars which are + ;; assumed to be comment-enders although they aren't. + ;; + ;; At beginning of range to scan, we're outside of strings; + ;; that determines quote parity to the comment-end. + (while (/= from stop) + (catch :continue + (let (temp-aref prev-syntax com2start com2end) + (dec-both from from-aref buffer) + (setf prev-syntax syntax + ch (buffer-fetch-char from-aref buffer) + syntax (&syntax-with-flags ch table) + code (&syntax ch table) + ;; Check for 2-char comment markers. + com2start (and (&syntax-flags-comment-start-first syntax) + (&syntax-flags-comment-start-second prev-syntax) + (eq comment-style (&syntax-flags-comment-style prev-syntax)) + (eq (or (&syntax-flags-comment-nested prev-syntax) + (&syntax-flags-comment-nested syntax)) + comment-nested)) + com2end (and (&syntax-flags-comment-end-first syntax) + (&syntax-flags-comment-end-second prev-syntax))) + ;; Nasty cases with overlapping 2-char comment markers: + ;; - snmp-mode: -- c -- foo -- c -- + ;; --- c -- + ;; ------ c -- + ;; - c-mode: *||* + ;; |* *|* *| + ;; |*| |* |*| + ;; /// */ - (dec-both pos pos-aref buffer) - (while (and (not (&char-quoted pos pos-aref buffer table)) - (progn - (setf c (buffer-fetch-char pos-aref buffer)) - (or (eq (&syntax c table) :quote) - (&syntax-prefix c table)))) - (setf opoint pos - opoint-aref pos-aref) - (when (> (1+ pos) beg) - (dec-both pos pos-aref buffer))) - (set-point-both buffer opoint opoint-aref) - nil)) - -(defstruct parse-state - depth min-depth - this-level-start - prev-level-start - location - level-starts - quoted - in-comment - comment-style - comment-string-start - in-string - start-value - start-value-aref) + ;; If a 2-char comment sequence partly overlaps with + ;; another, we don't try to be clever. + (when (and (> from stop) + (or com2end com2start)) + (let ((next from) + (next-aref from-aref) + next-c + next-syntax) + (dec-both next next-aref buffer) + (setf next-c (buffer-fetch-char next-aref buffer) + next-syntax (&syntax-with-flags next-c table)) + (when (or (and (or com2start comment-nested) + (&syntax-flags-comment-end-second syntax) + (&syntax-flags-comment-end-first next-syntax)) + (and (or com2end comment-nested) + (&syntax-flags-comment-start-second syntax) + (eq comment-style (&syntax-flags-comment-style syntax)) + (&syntax-flags-comment-start-first next-syntax))) + (signal 'syntax-lossage)))) -(defstruct syntax-level - last prev) + (when (and com2start + (= comment-start-pos 0)) + ;; We're looking at a comment starter. But it might be a comment + ;; ender as well (see snmp-mode). The first time we see one, we + ;; need to consider it as a comment starter, + ;; and the subsequent times as a comment ender. + (setf com2end 0)) + + ;; Turn a 2-char comment sequences into the appropriate syntax. + (cond (com2end + (setf code :end-comment)) + (com2start + (setf code :comment)) + ;; Ignore comment starters of a different style. + ((and (eq code :comment) + (or (not (eq comment-style (&syntax-flags-comment-style syntax))) + (not (eq comment-nested (&syntax-flags-comment-nested syntax))))) + (throw :continue nil))) -;; this function cries out for continuations. you almost have to look -;; at the C code to understand what's going on here, i bet. Hell, I -;; don't even understand it. -(defun scan-sexps-forward (from from-aref end target-depth stop-before old-state comment-stop buffer table) - "Parse forward from FROM / FROM_BYTE to END, -assuming that FROM has state OLDSTATE (nil means FROM is start of function), -and return a description of the state of the parse at END. -If STOPBEFORE is nonzero, stop at the start of an atom. -If COMMENTSTOP is 1, stop at the start of a comment. -If COMMENTSTOP is -1, stop at the start or end of a comment, -after the beginning of a string, or after the end of a string." - ;;(message "scan-sexps-forward ~@{~a ~}" from from-aref end target-depth stop-before old-state comment-stop buffer table) - (let ((state (make-parse-state)) - (prev-from from) - (prev-from-aref from-aref) - prev-from-syntax - (boundary-stop (null comment-stop)) - no-fence - c1 - code - comment-nested - depth - min-depth - temp - start-quoted - levels) - (labels ((inc-from () - (setf prev-from from - prev-from-aref from-aref - temp (buffer-fetch-char prev-from-aref buffer) - prev-from-syntax (&syntax-with-flags temp table)) - (inc-both from from-aref buffer)) - (cur-level () - "Return the current level struct" - (car levels)) - (do-start-in-comment () - ;; The (from == BEGV) test was to enter the loop in the middle so - ;; that we find a 2-char comment ender even if we start in the - ;; middle of it. We don't want to do that if we're just at the - ;; beginning of the comment (think of (*) ... (*)). - (multiple-value-bind (found out-char out-aref in-comment) - (&forward-comment from from-aref end - (parse-state-in-comment state) - (parse-state-comment-style state) - (if (or (eq from (begv buffer)) - (< from (+ (parse-state-comment-string-start state) 3))) - nil prev-from-syntax) - buffer table) - (setf from out-char - from-aref out-aref - (parse-state-in-comment state) in-comment) - ;; Beware! prev_from and friends are invalid now. - ;; Luckily, the `done' doesn't use them and the INC_FROM - ;; sets them to a sane value without looking at them. - (unless found (throw :end :done)) - (inc-from) - (setf (parse-state-in-comment state) nil - (parse-state-comment-style state) nil) ; reset the comment style - (when boundary-stop (throw :end :done)))) - (do-sym-done () - ;;(message "do-sym-done ~s" (parse-state-level-starts state)) - (setf (syntax-level-prev (cur-level)) (syntax-level-last (cur-level)))) - (do-sym-started () - ;; (message "do-sym-started") - (while (< from end) - (case (&syntax (buffer-fetch-char from-aref buffer) table) - ((:escape :character-quote) - (inc-from) - (when (= from end) - (throw :end :end-quoted))) - ((:word-constituent :symbol-constituent :quote)) - (t - (do-sym-done) - (return nil))) - (inc-from))) - (do-start-quoted () - (when (= from end) (throw :end :end-quoted)) - (inc-from) - (do-sym-started)) - (do-in-string-loop () - (loop - (let (c) - (when (>= from end) (throw :end :done)) - (setf c (buffer-fetch-char from-aref buffer) - temp (&syntax c table)) - ;; Check TEMP here so that if the char has - ;; a syntax-table property which says it is NOT - ;; a string character, it does not end the string. - (when (and no-fence - (equal c (parse-state-in-string state)) - (eq temp :string)) - (return nil)) - (case temp - (:string-fence - (unless no-fence (return nil))) - ((:character-quote :escape) - (inc-from) - (when (>= from end) (throw :end :end-quoted)))) - (inc-from)))) - (do-string-end () - ;;(message "do-string-end ~s" (parse-state-level-starts state)) - (setf (parse-state-in-string state) nil - (syntax-level-prev (cur-level)) (syntax-level-last (cur-level))) - (inc-from) - (when boundary-stop (throw :end :done))) - (do-start-in-string () - (setf no-fence (not (eq (parse-state-in-string state) :st-string-style))) - (do-in-string-loop) - (do-string-end)) - (do-start-quoted-in-string () - (when (>= from end) (throw :end :end-quoted)) - (inc-from) - (do-in-string-loop))) + ;; Ignore escaped characters, except comment-enders. + (when (and (not (eq code :end-comment)) + (&char-quoted from from-aref buffer table)) + (throw :continue nil)) + + (case code + ((:string-fence :comment-fence :string) + (when (find code '(:string-fence :comment-fence)) + (setf ch (if (eq code :string-fence) + :string-style + :comment-style))) + ;; Track parity of quotes. + (cond ((eq string-style :none) + ;; Entering a string. + (setf string-style ch)) + ((eq string-style ch) + ;; leaving the string + (setf string-style :none)) + (t + ;; If we have two kinds of string delimiters. + ;; There's no way to grok this scanning backwards. + (setf string-lossage t)))) + (:comment + ;; We've already checked that it is the relevant comstyle. + (when (or (eq string-style :none) + comment-lossage + string-lossage) + ;; There are odd string quotes involved, so let's be careful. + ;; Test case in Pascal: " { " a { " } */ + (signal 'syntax-lossage)) + (if (not comment-nested) + ;; Record best comment-starter so far. + (setf comment-start-pos from + comment-start-aref from-aref) + (progn + (decf nesting) + (when (<= nesting) + ;; nested comments have to be balanced, so we don't need to + ;; keep looking for earlier ones. We use here the same (slightly + ;; incorrect) reasoning as below: since it is followed by uniform + ;; paired string quotes, this comment-start has to be outside of + ;; strings, else the comment-end itself would be inside a string. + (signal 'syntax-done))))) + (:end-comment + (cond ((and (eq comment-style (&syntax-flags-comment-style syntax)) + (or (and com2end + (&syntax-flags-comment-nested prev-syntax)) + (eq comment-nested (&syntax-flags-comment-nested syntax)))) + ;; This is the same style of comment ender as ours. + (if comment-nested + (incf nesting) + ;; Anything before that can't count because it would match + ;; this comment-ender rather than ours. + (setf from stop))) + ((or (/= comment-start-pos 0) + (char/= ch #\Newline)) + ;; We're mixing comment styles here, so we'd better be careful. + ;; The (comstart_pos != 0 || c != '\n') check is not quite correct + ;; (we should just always set comment_lossage), but removing it + ;; would imply that any multiline comment in C would go through + ;; lossage, which seems overkill. + ;; The failure should only happen in the rare cases such as + ;; { (* } *) + (setf comment-lossage t)))) + (:open + ;; Assume a defun-start point is outside of strings. + (when (and *open-paren-in-column-0-is-defun-start* + (or (= from stop) + (progn + (setf temp-aref (aref-minus-1 from-aref buffer)) + (char= (buffer-fetch-char temp-aref buffer) #\Newline)))) + (setf defun-start from + defun-start-aref from-aref + ;; Break out of the loop. + from stop))))))) - (when (/= from (begv buffer)) - (dec-both prev-from prev-from-aref buffer)) + (if (= comment-start-pos 0) + (setf from comment-end + from-aref comment-end-aref) + ;; If comstart_pos is set and we get here (ie. didn't jump to `lossage' + ;; or `done'), then we've found the beginning of the non-nested comment. + (setf from comment-start-pos + from-aref comment-start-aref))) + (syntax-lossage () + ;; We had two kinds of string delimiters mixed up + ;; together. Decode this going forwards. + ;; Scan fwd from a known safe place (beginning-of-defun) + ;; to the one in question; this records where we + ;; last passed a comment starter. + ;; If we did not already find the defun start, find it now. + (when (= defun-start 0) + (let ((ret (find-defun-start comment-end comment-end-aref buffer table))) + (setf defun-start (parse-state-start-value ret) + defun-start-aref (parse-state-start-value-aref ret)))) + (loop do + (let ((state (scan-sexps-forward defun-start defun-start-aref + comment-end -10000 0 nil 0 buffer table))) + (setf defun-start comment-end) + (if (and (eq (parse-state-in-comment state) comment-nested) + (eq (parse-state-comment-style state) comment-style)) + (setf from (parse-state-comment-string-start state)) + (progn + (setf from comment-end) + (when (parse-state-in-comment state) ; XXX + ;; If comment_end is inside some other comment, maybe ours + ;; is nested, so we need to try again from within the + ;; surrounding comment. Example: { a (* " *) + (setf defun-start (+ (parse-state-comment-string-start state) 2) + defun-start-aref (buffer-char-to-aref buffer defun-start)))))) + while (< defun-start comment-end)) + (setf from-aref (buffer-char-to-aref buffer from)))) + (values (if (= from comment-end) -1 from) + from-aref))) + +(defun prev-char-comment-end-first (pos pos-aref buffer table) + "Return the SYNTAX_COMEND_FIRST of the character before POS, POS_BYTE." + (dec-both pos pos-aref buffer) + (&syntax-comment-end-first (buffer-fetch-char pos-aref buffer) + table)) - (if old-state - (progn - (setf state old-state - start-quoted (parse-state-quoted state) - depth (or (parse-state-depth state) 0) - start-quoted (parse-state-quoted state)) - (dolist (i (parse-state-level-starts state)) - (push (make-syntax-level :last i) levels)) - ;; make sure we have at least one in the list - (unless levels - (push (make-syntax-level) levels))) - (setf depth 0 - state (make-parse-state) - levels (list (make-syntax-level)))) +(defun &scan-lists (from count depth sexpflag &aux (buffer (current-buffer))) + "This is from the emacs function" + ;; the big TODO here is to use the CL readtable + (labels ((lose (last-good from) + (signal 'unbalanced-parenthesis :last-good last-good :from from))) + (let ((stop (if (> count 0) (zv buffer) (begv buffer))) + (from-aref (buffer-char-to-aref buffer from)) + (min-depth (min 0 depth)) + (table (syntax-table)) + (last-good from) + quoted + math-exit + comment-start-first + code + ch ch1 + temp-code + temp-pos + comment-nested + comment-style + found + prefix) + ;; normalize FROM + (setf from (max (min (zv buffer) from) + (begv buffer))) + (while (> count 0) + ;; the code needs to be able to jump out of the mess it got + ;; in. + (handler-case + (progn + (while (< from stop) + (catch :continue + (setf ch (buffer-fetch-char from-aref buffer) + code (&syntax ch table) + comment-start-first (&syntax-comment-start-first ch table) + comment-nested (&syntax-comment-nested ch table) + comment-style (&syntax-comment-style ch table) + prefix (&syntax-prefix ch table)) + (when (= depth min-depth) + (setf last-good from)) + (inc-both from from-aref buffer) + (when (and (< from stop) comment-start-first + (progn (setf ch (buffer-fetch-char from-aref buffer)) + (&syntax-comment-start-second ch table)) + *parse-sexp-ignore-comments*) + ;; we have encountered a comment start sequence and + ;; we are ignoring all text inside comments. We + ;; must record the comment style this sequence + ;; begins so that later, only a comment end of the + ;; same style actually ends the comment section + (setf code :comment + ch1 (buffer-fetch-char from-aref buffer) + comment-style (&syntax-comment-style ch1 table) + comment-nested (or comment-nested + (&syntax-comment-nested ch1 table))) + (inc-both from from-aref buffer)) - ;;(message "top ~s" (parse-state-level-starts state)) + (when prefix + (throw :continue nil)) - (setf (parse-state-quoted state) nil - min-depth depth) + (when (or (eq code :escape) + (eq code :character-quote)) + (when (= from stop) (lose last-good from)) + (inc-both from from-aref buffer) + ;; treat following character as a word constituent + (setf code :word-constituent)) - (setf temp (buffer-fetch-char prev-from-aref buffer) - prev-from-syntax (&syntax-with-flags temp table)) + (case code + ((:word-constituent :symbol-constituent) + (unless (or (not (zerop depth)) + (not sexpflag)) + (let (temp) + (while (< from stop) + (setf ch (buffer-fetch-char from-aref buffer) + temp (&syntax ch table)) + (case temp + ((:escape :character-quote) + (inc-both from from-aref buffer) + (when (= from stop) (lose last-good from))) + ((:word-constituent :symbol-constituent :quote)) + (t + (signal 'syntax-done))) + (inc-both from from-aref buffer))) + (signal 'syntax-done))) + ((:comment-fence :comment) + (when (eq code :comment-fence) + (setf comment-style :st-comment-style)) + (multiple-value-setq (found from from-aref) (&forward-comment from from-aref stop comment-nested comment-style nil buffer table)) + (unless found + (when (zerop depth) (signal 'syntax-done)) + (lose last-good from)) + (inc-both from from-aref buffer)) + (:math + (when sexpflag + (when (and (/= from stop) + (char= ch (buffer-fetch-char from-aref buffer))) + (inc-both from from-aref buffer)) + (if math-exit + (progn + (setf math-exit nil) + (decf depth) + (when (zerop depth) (signal 'syntax-done)) + (when (< depth min-depth) + (signal 'expression-ends-prematurely))) ; XXX + (progn + (setf math-exit t) + (incf depth) + (when (zerop depth) (signal 'syntax-done)))))) + (:open + (incf depth) + (when (zerop depth) (signal 'syntax-done))) + (:close + (decf depth) + (when (zerop depth) (signal 'syntax-done)) + (when (< depth min-depth) + (signal 'expression-ends-prematurely))) + ((:string :string-fence) + (let* ((tmp-pos (aref-minus-1 from-aref buffer)) + (string-term (buffer-fetch-char tmp-pos buffer)) + temp) + (loop + (when (>= from stop) (lose last-good from)) + (setf ch (buffer-fetch-char from-aref buffer)) + (when (if (eq code :string) + (and (char= ch string-term) + (eq (&syntax ch table) :string)) + (eq (&syntax ch table) :string-fence)) + (return nil)) + (setf temp (&syntax ch table)) + (case temp + ((:character-quote :escape) + (inc-both from from-aref buffer))) + (inc-both from from-aref buffer)) + (inc-both from from-aref buffer) + (when (and (zerop depth) + sexpflag) + (signal 'syntax-done)))) + (t + ;; Ignore whitespace, punctuation, quote, endcomment. + )))) + (unless (zerop depth) (lose last-good from)) + (return-from &scan-lists nil)) + (syntax-done () + (decf count)))) - ;; "Enter" the loop at a place appropriate for initial state. In - ;; the C code this is a bunch of goto's. Here we call the - ;; appropriate function that sync's us so we're ready to enter - ;; the loop. - (cond ((parse-state-in-comment state) - (do-start-quoted)) - ((parse-state-in-string state) - (setf no-fence (not (eq (parse-state-in-string state) :st-string-style))) - (if start-quoted - (do-start-quoted-in-string) - (do-start-in-string))) - (start-quoted - (do-start-quoted))) - ;; (message "sane here") - (case - (catch :end - (while (< from end) - (catch :continue - (inc-from) - (setf code (&syntax-flags-syntax prev-from-syntax)) - ;; (message "here the code is ~s" code) - (cond ((and (< from end) - (&syntax-flags-comment-start-first prev-from-syntax) - (progn - (setf c1 (buffer-fetch-char from-aref buffer)) - (&syntax-comment-start-second c1 table))) - ;; (message "here 1") - ;; Record the comment style we have entered so that only - ;; the comment-end sequence of the same style actually - ;; terminates the comment section. - (setf (parse-state-comment-style state) (&syntax-comment-style c1 table) - comment-nested (&syntax-flags-comment-nested prev-from-syntax) - comment-nested (or comment-nested - (&syntax-comment-nested c1 table)) - (parse-state-in-comment state) comment-nested - (parse-state-comment-string-start state) prev-from) - (inc-from) - (setf code :comment)) - ((eq code :comment-fence) - ;; (message "here 2") - ;; Record the comment style we have entered so that only - ;; the comment-end sequence of the same style actually - ;; terminates the comment section. - (setf (parse-state-comment-style state) :st-comment-style - (parse-state-in-comment state) -1 ; XXX - (parse-state-comment-string-start state) prev-from - code :comment)) - ((eq code :comment) - ;; (message "here 3") - (setf (parse-state-comment-style state) (&syntax-flags-comment-style prev-from-syntax) - (parse-state-in-comment state) (&syntax-flags-comment-nested prev-from-syntax) - (parse-state-comment-string-start state) prev-from))) + (while (< count 0) + (handler-case + (progn + (while (> from stop) + (catch :continue + (dec-both from from-aref buffer) + (setf ch (buffer-fetch-char from-aref buffer) + code (&syntax ch table)) + (when (= depth min-depth) + (setf last-good from)) + (setf comment-style nil + comment-nested (&syntax-comment-nested ch table)) + (when (eq code :end-comment) + (setf comment-style (&syntax-comment-style ch table))) + (when (and (> from stop) + (&syntax-comment-end-second ch table) + (prev-char-comment-end-first from from-aref buffer table) + *parse-sexp-ignore-comments*) + ;; We must record the comment style + ;; encountered so that later, we can match + ;; only the proper comment begin sequence of + ;; the same style. + (dec-both from from-aref buffer) + (setf code :end-comment + ch1 (buffer-fetch-char from-aref buffer) + comment-nested (or comment-nested + (&syntax-comment-nested ch1 table)))) + ;; Quoting turns anything except a comment-ender + ;; into a word character. Note that this cannot + ;; be true if we decremented FROM in the + ;; if-statement above. + (cond + ((and (not (eq code :end-comment)) + (&char-quoted from from-aref buffer table)) + (dec-both from from-aref buffer) + (setf code :word)) + ((&syntax-prefix ch table) + ;; loop around again. I think this is nasty but fuckit. + (throw :continue nil))) + (case code + ((:word-constituent :symbol-constituent :escape :character-quote) + (unless (or (not (zerop depth)) + (not sexpflag)) + ;; This word counts as a sexp; count + ;; object finished after passing it. + (while (> from stop) + (setf temp-pos from-aref) + (decf temp-pos) + (setf ch1 (buffer-fetch-char temp-pos buffer) + temp-code (&syntax ch1 table)) + ;; Don't allow comment-end to be quoted. + (when (eq temp-code :end-comment) + (signal 'syntax-done)) + (setf quoted (&char-quoted (1- from) temp-pos buffer table)) + (when quoted + (dec-both from from-aref buffer) + (setf temp-pos (aref-minus-1 temp-pos buffer))) + (setf ch1 (buffer-fetch-char temp-pos buffer) + temp-code (&syntax ch1 table)) + (when (not (or quoted + (eq temp-code :word-constituent) + (eq temp-code :symbol-constituent) + (eq temp-code :quote))) + (signal 'syntax-done)) + (dec-both from from-aref buffer)) + (signal 'syntax-done))) + (:math + (when sexpflag + (setf temp-pos (aref-minus-1 from-aref buffer)) + (when (and (/= from stop) + (char= ch (buffer-fetch-char temp-pos buffer))) + (dec-both from from-aref buffer)) + (if math-exit + (progn + (setf math-exit nil) + (decf depth) + (when (zerop depth) (signal 'syntax-done)) + (when (< depth min-depth) + (signal 'expression-ends-prematurely))) + (progn + (setf math-exit t) + (incf depth) + (when (zerop depth) (signal 'syntax-done)))))) + (:close + (incf depth) + (when (zerop depth) (signal 'syntax-done))) + (:open + (decf depth) + (when (zerop depth) (signal 'syntax-done)) + (when (< depth min-depth) + (signal 'expression-ends-prematurely))) + (:end-comment + (when *parse-sexp-ignore-comments* + (multiple-value-bind (found char-pos aref-pos) + (&back-comment from from-aref stop comment-nested comment-style buffer table) + (when (eq found :not-comment-end) + (setf from char-pos + from-aref aref-pos))))) + ((:comment-fence :string-fence) + (loop + (when (= from stop) (lose last-good from)) + (dec-both from from-aref buffer) + (when (and (not (&char-quoted from from-aref buffer table)) + (progn + (setf ch (buffer-fetch-char from-aref buffer)) + (eq (&syntax ch table) code))) + (return nil))) + (when (and (eq code :string-fence) + (zerop depth) + sexpflag) + (signal 'syntax-done))) + (:string + (let ((string-term (buffer-fetch-char from-aref buffer))) + (loop + (when (= from stop) (lose last-good from)) + (dec-both from from-aref buffer) + (when (and (not (&char-quoted from from-aref buffer table)) + (progn + (setf ch (buffer-fetch-char from-aref buffer)) + (char= string-term ch)) + (eq (&syntax ch table) :string)) + (return nil))) + (when (and (zerop depth) + sexpflag) + (signal 'syntax-done)))) + (t + ;; Ignore whitespace, punctuation, quote, endcomment. + )))) + (when (not (zerop depth)) (lose last-good from)) + (return-from &scan-lists nil)) + (syntax-done () + (incf count)))) + from))) - (when (&syntax-flags-prefix prev-from-syntax) - (throw :continue nil)) +(defun scan-lists (from count depth) + "Scan from character number FROM by COUNT lists. +Returns the character number of the position thus found. - ;;(message "code: ~s" code) - (case code - ((:escape :character-quote) - ;; this arg means stop at sexp start - (when stop-before (throw :end :stop)) - ;;(message ":escae ~s" (parse-state-level-starts state)) - (setf (syntax-level-last (cur-level)) prev-from) - (do-start-quoted)) +If DEPTH is nonzero, paren depth begins counting from that value, +only places where the depth in parentheses becomes zero +are candidates for stopping; COUNT such places are counted. +Thus, a positive value for DEPTH means go out levels. - ((:word-constituent :symbol-constituent) - (when stop-before (throw :end :stop)) - ;;(message ":word-con ~s" (parse-state-level-starts state)) - (setf (syntax-level-last (cur-level)) prev-from) - (do-sym-started)) +Comments are ignored if `*parse-sexp-ignore-comments*' is non-nil. - ((:comment-fence :comment) - (when (or comment-stop - boundary-stop) - (throw :end :done)) - (do-start-in-comment)) +If the beginning or end of (the accessible part of) the buffer is reached +and the depth is wrong, an error is signaled. +If the depth is right but the count is not used up, nil is returned." + (check-type from number) + (check-type count number) + (check-type depth number) + (&scan-lists from count depth nil)) - (:open - (when stop-before (throw :end :stop)) - (incf depth) - ;;(message ":open ~s" (parse-state-level-starts state)) - (setf (syntax-level-last (cur-level)) prev-from) - ;; (message ":open ~a" (parse-state-level-starts state)) - (push (make-syntax-level) levels) - ;; (when (> (length level-list) 100) ; XXX hardcoded - ;; (error "nesting too deep for parser")) - (when (= target-depth depth) (throw :end :done))) +(defun scan-sexps (from count) + "Scan from character number FROM by COUNT balanced expressions. +If COUNT is negative, scan backwards. +Returns the character number of the position thus found. - (:close - (decf depth) - (when (< depth min-depth) - (setf min-depth depth)) - (unless (= (length levels) 1) - (message "XXX: popping when levels is 1!") - (pop levels)) - (setf (syntax-level-prev (cur-level)) (syntax-level-last (cur-level))) - (when (= target-depth depth) - (throw :end :done))) +Comments are ignored if `parse-sexp-ignore-comments' is non-nil. - ((:string :string-fence) - (setf (parse-state-comment-string-start state) (1- from)) - (when stop-before - (throw :end :stop)) - (setf (syntax-level-last (cur-level)) prev-from) - (setf (parse-state-in-string state) (if (eq code :string) - (buffer-fetch-char prev-from-aref buffer) - :st-string-style)) - (when boundary-stop - (throw :end :done)) - (do-start-in-string)) +If the beginning or end of (the accessible part of) the buffer is reached +in the middle of a parenthetical grouping, an error is signaled. +If the beginning or end is reached between groupings +but before count is used up, nil is returned." + (check-type from number) + (check-type count number) + (&scan-lists from count 0 t)) - (:math - ;; FIXME: We should do something with it. - ) - (t - ;; Ignore whitespace, punctuation, quote, endcomment. - )))) - :done) - (:stop - ;; Here if stopping before start of sexp. - ;; We have just fetched the char that starts it - ;; but return the position before it. - (setf from prev-from)) - (:end-quoted - (setf (parse-state-quoted state) t))) +(defun backward-prefix-chars (&aux (buffer (current-buffer)) (table (syntax-table))) + "Move point backward over any number of chars with prefix syntax. +This includes chars with \"quote\" or \"prefix\" syntax (' or p)." + (let* ((beg (begv buffer)) + (pos (pt buffer)) + (pos-aref (buffer-char-to-aref buffer pos)) + (opoint (pt buffer)) + (opoint-aref (buffer-char-to-aref buffer pos)) + c) + (when (<= pos beg) + ;; SET_PT_BOTH (opoint, opoint_byte); + (return-from backward-prefix-chars nil)) - ;;(message ":end ~s" (parse-state-level-starts state)) - ;; done - (setf (parse-state-depth state) depth - (parse-state-min-depth state) min-depth - (parse-state-this-level-start state) (syntax-level-prev (cur-level)) - (parse-state-prev-level-start state) (if (<= (length levels) 1) - nil (syntax-level-last (second levels))) - (parse-state-location state) from - (parse-state-level-starts state) (mapcar 'syntax-level-last (cdr levels))) - state))) + (dec-both pos pos-aref buffer) + (while (and (not (&char-quoted pos pos-aref buffer table)) + (progn + (setf c (buffer-fetch-char pos-aref buffer)) + (or (eq (&syntax c table) :quote) + (&syntax-prefix c table)))) + (setf opoint pos + opoint-aref pos-aref) + (when (> (1+ pos) beg) + (dec-both pos pos-aref buffer))) + (set-point-both buffer opoint opoint-aref) + nil)) (defun parse-partial-sexp (from to &key (target-depth -100000) stop-before old-state comment-stop &aux (buffer (current-buffer)) (table (syntax-table))) "Parse Lisp syntax starting at FROM until TO; return status of parse at TO. @@ -1600,5 +1534,5 @@ Sixth arg COMMENTSTOP non-nil means stop at the start of a comment. (if (eq comment-stop 'syntax-table) -1 1) 0) buffer table))) - (goto-char (parse-state-location state) buffer) + (set-point (parse-state-location state) buffer) state)) diff --git a/text-mode.lisp b/text-mode.lisp index fca61b0..63fc63d 100644 --- a/text-mode.lisp +++ b/text-mode.lisp @@ -83,7 +83,7 @@ You can thus get the full benefit of adaptive filling (defcommand text-mode () "See `*text-mode*'." - (set-major-mode *text-mode*)) + (set-major-mode '*text-mode*)) (defvar *paragraph-indent-text-mode* (make-instance 'major-mode @@ -104,7 +104,7 @@ Turning on Paragraph-Indent Text mode runs the normal hooks (defcommand paragraph-indent-text-mode () "see `*paragraph-indent-text-mode*'." - (set-major-mode *paragraph-indent-text-mode*)) + (set-major-mode '*paragraph-indent-text-mode*)) (defcommand paragraph-indent-minor-mode () "Minor mode for editing text, with leading spaces starting a paragraph. diff --git a/textprop.lisp b/textprop.lisp index 1eda424..a73f19e 100644 --- a/textprop.lisp +++ b/textprop.lisp @@ -1,4 +1,4 @@ -(in-package :lice) +(in-package "LICE") (defvar *inhibit-point-motion-hooks* nil "If non-nil, don't run `point-left' and `point-entered' text properties. @@ -44,6 +44,17 @@ This also inhibits the use of the `intangible' text property.") (values (create-root-interval object) begin end) (values i begin end))))) +(defun validate-plist (list) + "/* Validate LIST as a property list. If LIST is not a list, then +make one consisting of (LIST nil). Otherwise, verify that LIST is +even numbered and thus suitable as a plist. */" + (cond ((null list) nil) + ((consp list) + (if (oddp (length list)) + (error "odd length property list") + list)) + (t (list (list list nil))))) + (defun set-text-properties (start end properties &optional (object (current-buffer))) (let ((start-bk start) (end-bk end) @@ -84,64 +95,6 @@ This also inhibits the use of the `intangible' text property.") ;; XINT (end) - XINT (start)); t)) -(defun set-text-properties-1 (start end properties buffer i) - (let ((len (- end start)) - (prev-changed nil) - unchanged) - (when (zerop len) - (return-from set-text-properties-1)) - (when (minusp len) - (incf start len) - (setf len (abs len))) - (when (null i) - (setf i (find-interval (intervals buffer) start))) - (when (/= (interval-pt i) start) - (setf unchanged i - i (split-interval-right unchanged (- start (interval-pt unchanged)))) - (when (> (interval-text-length i) len) - (copy-properties unchanged i) - (setf i (split-interval-left i len)) - (set-properties properties i buffer) - (return-from set-text-properties-1)) - (set-properties properties i buffer) - (when (= (interval-text-length i) len) - (return-from set-text-properties-1)) - (setf prev-changed i) - (decf len (interval-text-length i)) - (setf i (next-interval i))) - (while (> len 0) - (when (null i) - (error "borked.")) - (when (>= (interval-text-length i) len) - (when (> (interval-text-length i) len) - (setf i (split-interval-left i len))) - (set-properties properties i buffer) - (when prev-changed - (merge-interval-left i)) - (return-from set-text-properties-1)) - (decf len (interval-text-length i)) - ;; We have to call set_properties even if we are going - ;; to merge the intervals, so as to make the undo - ;; records and cause redisplay to happen. - (set-properties properties i buffer) - (if (null prev-changed) - (setf prev-changed i) - (setf prev-changed (merge-interval-left i) - i prev-changed)) - (setf i (next-interval i))))) - -(defun copy-properties (source target) - (when (and (default-interval-p source) - (default-interval-p target)) - (return-from copy-properties)) - (setf (interval-plist target) (copy-list (interval-plist source)))) - -(defun set-properties (properties interval object) - (when (typep object 'buffer) - ;; record undo info - ) - (setf (interval-plist interval) (copy-tree properties))) - (defun add-properties (plist i object) "Add the properties in plist to interval I. OBJECT should be the string of buffer containing the interval." @@ -160,17 +113,6 @@ string of buffer containing the interval." (setf (getf (interval-plist i) sym) val changed t))))))) -(defun validate-plist (list) - "/* Validate LIST as a property list. If LIST is not a list, then -make one consisting of (LIST nil). Otherwise, verify that LIST is -even numbered and thus suitable as a plist. */" - (cond ((null list) nil) - ((consp list) - (if (oddp (length list)) - (error "odd length property list") - list)) - (t (list (list list nil))))) - (defun interval-has-all-properties (plist i) "/* Return nonzero if interval I has all the properties, with the same values, of list PLIST. */" @@ -296,41 +238,6 @@ into it." (setf modified (remove-properties properties nil i object) i (next-interval i))))) -(defun next-single-char-property-change (position prop &optional (object (current-buffer)) limit) - "/* Return the position of next text property or overlay change for a specific property. -Scans characters forward from POSITION till it finds -a change in the PROP property, then returns the position of the change. -If the optional third argument OBJECT is a buffer (or nil, which means -the current buffer), POSITION is a buffer position (integer or marker). -If OBJECT is a string, POSITION is a 0-based index into it. - -The property values are compared with `eql' by default. -If the property is constant all the way to the end of OBJECT, return the -last valid position in OBJECT. -If the optional fourth argument LIMIT is non-nil, don't search -past position LIMIT; return LIMIT if nothing is found before LIMIT. */" - (if (typep object 'pstring) - (progn - (setf position (next-single-property-change position prop object limit)) - (unless position - (if (null limit) - (setf position (pstring-length object)) - (setf position limit)))) - (let ((initial-value (get-char-property position prop object)) - value) -;; (when (and (typep object 'buffer) -;; (not (eq object (current-buffer)))) -;; ( - (when (null limit) - (setf limit (buffer-max object))) - (loop - (setf position (next-char-property-change position limit object)) - (when (>= position limit) - (return limit)) - (setf value (get-char-property position prop object)) - (unless (eq value initial-value) - (return position)))))) - (defun text-properties-at (position &optional (object (current-buffer))) (multiple-value-bind (i position) (validate-interval-range object position position t) (unless (null i) @@ -340,7 +247,7 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */" ;; since no character follows. (unless (= position (+ (interval-text-length i) (interval-pt i))) (interval-plist i))))) - + (defun get-text-property (position prop &optional (object (current-buffer))) (getf (text-properties-at position object) prop)) @@ -351,26 +258,42 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT. */" (defun get-char-property (position prop &optional (object (current-buffer))) (get-char-property-and-overlay position prop object 0)) -(defun previous-single-char-property-change (position prop &optional (object (current-buffer)) limit) - (cond ((typep object 'pstring) - (setf position (previous-single-property-change position prop object limit)) - (when (null position) - (setf position (or limit - (pstring-length object))))) - (t - (unless limit - (setf limit (buffer-min object))) - (if (<= position limit) - (setf position limit) - (let ((initial-value (get-char-property (1- position) prop object)) - value) - (loop - (setf position (previous-char-property-change position limit object)) - (when (<= position limit) - (return limit)) - (setf value (get-char-property (1- position) prop object)) - (unless (eq value initial-value) - (return position)))))))) +(defun previous-property-change (position &optional (object (current-buffer)) limit) + "Return the position of previous property change. +Scans characters backwards from POSITION in OBJECT till it finds +a change in some text property, then returns the position of the change. +If the optional second argument OBJECT is a buffer (or nil, which means +the current buffer), POSITION is a buffer position (integer or marker). +If OBJECT is a string, POSITION is a 0-based index into it. +Return nil if the property is constant all the way to the start of OBJECT. +If the value is non-nil, it is a position less than POSITION, never equal. + +If the optional third argument LIMIT is non-nil, don't search +back past position LIMIT; return LIMIT if nothing is found until LIMIT." + (let (i previous) + (multiple-value-setq (i position) (validate-interval-range object position position nil)) + (unless i + (return-from previous-property-change limit)) + (when (= (interval-pt i) position) + (setf i (previous-interval i))) + (setf previous (previous-interval i)) + (while (and previous + (intervals-equal previous i) + (or (null limit) + (> (+ (interval-pt previous) + (interval-text-length previous)) + limit))) + (setf previous (previous-interval previous))) + ;; FIXME: this code needs cleaning + (when (null previous) + (return-from previous-property-change limit)) + (setf limit (or limit + (cond ((typep object 'pstring) 0) + ((typep object 'buffer) (buffer-min object))))) + (when (<= (+ (interval-pt previous) (interval-text-length previous)) + limit) + (return-from previous-property-change limit)) + (+ (interval-pt previous) (interval-text-length previous)))) (defun next-property-change (position &optional object limit) "Return the position of next property change. @@ -415,7 +338,7 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT." ;; FIXME: This is silly code. (setf position (interval-pt next)) position)) - + (defun next-char-property-change (position &optional limit (buffer (current-buffer))) "Return the position of next text property or overlay change. This scans characters forward in the current buffer from POSITION till @@ -428,17 +351,6 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT." ;; temp = Fnext_overlay_change (position); (next-property-change position buffer (or limit (buffer-max buffer)))) -(defun previous-char-property-change (position &optional limit (buffer (current-buffer))) - "Return the position of previous text property or overlay change. -Scans characters backward in the current buffer from POSITION till it -finds a change in some text property, or the beginning or end of an -overlay, and returns the position of that. -If none is found, the function returns (point-max). - -If the optional third argument LIMIT is non-nil, don't search -past position LIMIT; return LIMIT if nothing is found before LIMIT." - (previous-property-change position buffer (or limit (buffer-min buffer)))) - (defun next-single-property-change (position prop &optional (object (current-buffer)) limit) (let (i next here-val) (multiple-value-setq (i position) @@ -491,42 +403,72 @@ past position LIMIT; return LIMIT if nothing is found before LIMIT." (return-from previous-single-property-change limit)) (+ (interval-pt previous) (interval-text-length previous)))) -(defun previous-property-change (position &optional (object (current-buffer)) limit) - "Return the position of previous property change. -Scans characters backwards from POSITION in OBJECT till it finds -a change in some text property, then returns the position of the change. -If the optional second argument OBJECT is a buffer (or nil, which means +(defun previous-char-property-change (position &optional limit (buffer (current-buffer))) + "Return the position of previous text property or overlay change. +Scans characters backward in the current buffer from POSITION till it +finds a change in some text property, or the beginning or end of an +overlay, and returns the position of that. +If none is found, the function returns (point-max). + +If the optional third argument LIMIT is non-nil, don't search +past position LIMIT; return LIMIT if nothing is found before LIMIT." + (previous-property-change position buffer (or limit (buffer-min buffer)))) + +(defun next-single-char-property-change (position prop &optional (object (current-buffer)) limit) + "/* Return the position of next text property or overlay change for a specific property. +Scans characters forward from POSITION till it finds +a change in the PROP property, then returns the position of the change. +If the optional third argument OBJECT is a buffer (or nil, which means the current buffer), POSITION is a buffer position (integer or marker). If OBJECT is a string, POSITION is a 0-based index into it. -Return nil if the property is constant all the way to the start of OBJECT. -If the value is non-nil, it is a position less than POSITION, never equal. -If the optional third argument LIMIT is non-nil, don't search -back past position LIMIT; return LIMIT if nothing is found until LIMIT." - (let (i previous) - (multiple-value-setq (i position) (validate-interval-range object position position nil)) - (unless i - (return-from previous-property-change limit)) - (when (= (interval-pt i) position) - (setf i (previous-interval i))) - (setf previous (previous-interval i)) - (while (and previous - (intervals-equal previous i) - (or (null limit) - (> (+ (interval-pt previous) - (interval-text-length previous)) - limit))) - (setf previous (previous-interval previous))) - ;; FIXME: this code needs cleaning - (when (null previous) - (return-from previous-property-change limit)) - (setf limit (or limit - (cond ((typep object 'pstring) 0) - ((typep object 'buffer) (buffer-min object))))) - (when (<= (+ (interval-pt previous) (interval-text-length previous)) - limit) - (return-from previous-property-change limit)) - (+ (interval-pt previous) (interval-text-length previous)))) +The property values are compared with `eql' by default. +If the property is constant all the way to the end of OBJECT, return the +last valid position in OBJECT. +If the optional fourth argument LIMIT is non-nil, don't search +past position LIMIT; return LIMIT if nothing is found before LIMIT. */" + (if (typep object 'pstring) + (progn + (setf position (next-single-property-change position prop object limit)) + (unless position + (if (null limit) + (setf position (pstring-length object)) + (setf position limit)))) + (let ((initial-value (get-char-property position prop object)) + value) +;; (when (and (typep object 'buffer) +;; (not (eq object (current-buffer)))) +;; ( + (when (null limit) + (setf limit (buffer-max object))) + (loop + (setf position (next-char-property-change position limit object)) + (when (>= position limit) + (return limit)) + (setf value (get-char-property position prop object)) + (unless (eq value initial-value) + (return position)))))) + +(defun previous-single-char-property-change (position prop &optional (object (current-buffer)) limit) + (cond ((typep object 'pstring) + (setf position (previous-single-property-change position prop object limit)) + (when (null position) + (setf position (or limit + (pstring-length object))))) + (t + (unless limit + (setf limit (buffer-min object))) + (if (<= position limit) + (setf position limit) + (let ((initial-value (get-char-property (1- position) prop object)) + value) + (loop + (setf position (previous-char-property-change position limit object)) + (when (<= position limit) + (return limit)) + (setf value (get-char-property (1- position) prop object)) + (unless (eq value initial-value) + (return position)))))))) (defun text-property-stickiness (prop pos &optional (buffer (current-buffer))) "Return the direction from which the text-property PROP would be diff --git a/tty-render.lisp b/tty-render.lisp index 5db9a72..f7f6e0f 100644 --- a/tty-render.lisp +++ b/tty-render.lisp @@ -1,6 +1,6 @@ ;; TTY rendering routines -(in-package :lice) +(in-package "LICE") (defclass tty-frame (frame) ((double-buffer :type (array character 1) :initarg :double-buffer :accessor frame-double-buffer :documentation @@ -151,7 +151,7 @@ the text properties present." (cl-ncurses::attroff (cl-ncurses::COLOR-PAIR 1)) ;; Update the mode-line if it exists. FIXME: Not the right place ;; to update the mode-line. - (when (buffer-mode-line (window-buffer w)) + (when (buffer-local '*mode-line-format* (window-buffer w)) (update-mode-line (window-buffer w)) ;;(cl-ncurses::attron cl-ncurses::A_REVERSE) (cl-ncurses::attron (cl-ncurses::COLOR-PAIR 2)) @@ -247,7 +247,7 @@ the text properties present." :width cols :height lines :window-tree (list w mb) - :current-window w + :selected-window w :minibuffer-window mb :double-buffer l :2d-double-buffer d))) @@ -272,7 +272,7 @@ the text properties present." :width cols :height lines :window-tree (list w mb) - :current-window w + :selected-window w :minibuffer-window mb :double-buffer l :2d-double-buffer d))) diff --git a/undo.lisp b/undo.lisp dissimilarity index 64% index d8fdb53..9ac1cd5 100644 --- a/undo.lisp +++ b/undo.lisp @@ -1,622 +1,239 @@ -;;; undo code from undo.c - -(in-package "LICE") - -(defvar *last-undo-buffer* nil - "Last buffer for which undo information was recorded.") - -;; FIXME: a global used in these functions is probably bad wrt concurrency -(defvar *pending-boundary* nil - "The first time a command records something for undo. -it also allocates the undo-boundary object -which will be added to the list at the end of the command. -This ensures we can't run out of space while trying to make -an undo-boundary.") - -(defun ensure-pending-boundary () - "Allocate a cons cell to be the undo boundary after this command." - (when (null *pending-boundary*) - (setf *pending-boundary* (cons nil nil)))) - -(defun ensure-last-undo-buffer (&optional (buffer (current-buffer))) - (unless (eq buffer *last-undo-buffer*) - (undo-boundary buffer)) - (setf *last-undo-buffer* buffer)) - -(defun record-point (pt &optional (buffer (current-buffer))) - "Record point as it was at beginning of this command (if necessary) -And prepare the undo info for recording a change. -PT is the position of point that will naturally occur as a result of the -undo record that will be added just after this command terminates." - (let (at-boundary) - (ensure-pending-boundary) - (ensure-last-undo-buffer buffer) - (if (consp (buffer-undo-list buffer)) - ;; Set AT_BOUNDARY to 1 only when we have nothing other than - ;; marker adjustment before undo boundary. - (setf at-boundary (loop - for elt in (buffer-undo-list buffer) - while (typep elt 'undo-entry-marker) - finally (return (null elt)))) - (setf at-boundary t)) - ;; FIXME - ;; if (MODIFF <= SAVE_MODIFF) - ;; record_first_change (); - (when (and at-boundary - ;; If we're called from batch mode, this could be nil. - (eq buffer *last-point-position-buffer*)) - ;; If we have switched windows, use the point value - ;; from the window we are in. - (unless (eq *last-point-position-window* (selected-window)) - (setf *last-point-position* (marker-position (window-point (selected-window))))) - (when (/= *last-point-position* pt) - (push *last-point-position* (buffer-undo-list buffer)))))) - -(defun record-insert (beg length &optional (buffer (current-buffer))) - "Record an insertion that just happened or is about to happen, for -LENGTH characters at position BEG. (It is possible to record an -insertion before or after the fact because we don't need to record -the contents.)" - (when (eq (buffer-undo-list buffer) t) - (return-from record-insert nil)) - (record-point beg buffer) - ;; If this is following another insertion and consecutive with it - ;; in the buffer, combine the two. - (when (consp (buffer-undo-list buffer)) - (let ((elt (car (buffer-undo-list buffer)))) - (when (and (typep elt 'undo-entry-insertion) - (= (undo-entry-insertion-end elt) beg)) - (setf (undo-entry-insertion-end elt) (+ beg length)) - (return-from record-insert nil)))) - - (push (make-undo-entry-insertion :beg beg :end (+ beg length)) (buffer-undo-list buffer))) - -(defun record-delete (beg string &optional (buffer (current-buffer))) - "Record that a deletion is about to take place, of the -characters in STRING, at location BEG." - (when (eq (buffer-undo-list buffer) t) - (return-from record-delete nil)) - (if (= (point) (+ beg (length string))) - (progn - (setf beg (- beg)) - (record-point (point))) - (record-point beg)) - (push (make-undo-entry-delete :position beg :text string) - (buffer-undo-list buffer))) - -(defun record-marker-adjustment (marker adjustment &optional (buffer (current-buffer))) - "Record the fact that MARKER is about to be adjusted by ADJUSTMENT. -This is done only when a marker points within text being deleted, -because that's the only case where an automatic marker adjustment -won't be inverted automatically by undoing the buffer modification." - (when (eq (buffer-undo-list buffer) t) - (return-from record-marker-adjustment nil)) - (unless *pending-boundary* - (setf *pending-boundary* (cons nil nil))) - (unless (eq buffer *last-undo-buffer*) - (undo-boundary buffer)) - (setf *last-undo-buffer* buffer) - (push (make-undo-entry-marker :marker marker :adjustment adjustment) - (buffer-undo-list buffer))) - -(defun record-change (beg length &optional (buffer (current-buffer))) - "Record that a replacement is about to take place, -for LENGTH characters at location BEG. -The replacement must not change the number of characters." - (record-delete beg (buffer-substring beg (+ beg length) buffer)) - (record-insert beg length)) - -(defun record-first-change (&optional (buffer (current-buffer))) - "Record that an unmodified buffer is about to be changed. -Record the file modification date so that when undoing this entry -we can tell whether it is obsolete because the file was saved again." - (when (eq (buffer-undo-list buffer) t) - (return-from record-first-change nil)) - - (unless (eq buffer *last-undo-buffer*) - (undo-boundary buffer)) - (setf *last-undo-buffer* buffer) - - ;; FIXME - ;; if (base_buffer->base_buffer) - ;; base_buffer = base_buffer->base_buffer; - - ;; FIXME: implement modtime - (push (make-undo-entry-modified :time nil) - (buffer-undo-list buffer))) - -(defun record-property-change (beg length prop value buffer) - "Record a change in property PROP (whose old value was VAL) -for LENGTH characters starting at position BEG in BUFFER." - (let (boundary) - (when (eq (buffer-undo-list buffer) t) - (return-from record-property-change nil)) - - (ensure-pending-boundary) - (unless (eq buffer *last-undo-buffer*) - (setf boundary t)) - (setf *last-undo-buffer* buffer) - (when boundary - (undo-boundary buffer)) - ;; FIXME - ;; if (MODIFF <= SAVE_MODIFF) - ;; record_first_change (); - - (push (make-undo-entry-property :prop prop :value value :beg beg :end (+ beg length)) - (buffer-undo-list buffer)))) - -(defun undo-boundary (&optional (buffer (current-buffer))) - "Mark a boundary between units of undo. -An undo command will stop at this point, -but another undo command will undo to the previous boundary." - (when (eq (buffer-undo-list buffer) t) - (return-from undo-boundary nil)) - (when (car (buffer-undo-list buffer)) - ;; One way or another, cons nil onto the front of the undo list. - (if *pending-boundary* - ;; If we have preallocated the cons cell to use here, use that one. ; why the little dance? -sabetts - (setf (cdr *pending-boundary*) (buffer-undo-list buffer) - (buffer-undo-list buffer) *pending-boundary* - *pending-boundary* nil) - (push nil (buffer-undo-list buffer))) - nil)) - -(defgeneric primitive-undo-elt (undo-elt) - ) - -(defmethod primitive-undo-elt ((elt integer)) - "Handle an integer by setting point to that value." - (set-point (clip-to-bounds (begv) elt (zv)))) - -(defmethod primitive-undo-elt ((elt undo-entry-insertion)) - (when (or (< (undo-entry-insertion-beg elt) (begv)) - (> (undo-entry-insertion-end elt) (zv))) - (error "Changes to be undone are outside visible portion of buffer")) - (goto-char (undo-entry-insertion-beg elt)) - (delete-region (undo-entry-insertion-beg elt) - (undo-entry-insertion-end elt))) - -(defmethod primitive-undo-elt ((elt undo-entry-delete)) - (let ((pos (undo-entry-delete-position elt)) - (text (undo-entry-delete-text elt))) - (if (minusp pos) - (progn - (when (or (< (- pos) (begv)) - (> (- pos) (zv))) - (error "Changes to be undone are outside visible portion of buffer")) - (set-point (- pos)) - (insert text)) - (progn - (when (or (< pos (begv)) - (> pos (zv))) - (error "Changes to be undone are outside visible portion of buffer")) - (set-point pos) - (insert text) - (set-point pos))))) - -(defmethod primitive-undo-elt ((undo-elt undo-entry-modified)) - (error "unimplented")) - -(defmethod primitive-undo-elt ((elt undo-entry-property)) - (put-text-property (undo-entry-property-beg elt) - (undo-entry-property-end elt) - (undo-entry-property-prop elt) - (undo-entry-property-value elt) - nil)) - -(defmethod primitive-undo-elt ((undo-elt undo-entry-apply)) - (error "unimplented")) - -(defmethod primitive-undo-elt ((undo-elt undo-entry-selective)) - (error "unimplented")) - -(defmethod primitive-undo-elt ((elt undo-entry-marker)) - (let ((marker (undo-entry-marker-marker elt))) - (when (marker-buffer marker) - (set-marker marker (- (marker-position marker) - (undo-entry-marker-distance elt)) - (marker-buffer marker))))) - -(defun primitive-undo (n list) - "Undo N records from the front of the list LIST. -Return what remains of the list." - (check-type n integer) - (let ( ;; Don't let `intangible' properties interfere with undo. - (*inhibit-point-motion-hooks* t) - ;; In a writable buffer, enable undoing read-only text that is so - ;; because of text properties. - (*inhibit-read-only* t)) - (dotimes (arg n) - (while (consp list) - (let ((elt (pop list))) - ;; Exit inner loop at undo boundary. - (when (null elt) - (return nil)) - (primitive-undo-elt elt)))) - ;; Make sure an apply entry produces at least one undo entry, - ;; so the test in `undo' for continuing an undo series - ;; will work right. - list)) - -;;; undo code from simple.el - -;; XXX: gnu emacs uses a weak hashtable that automatically removes -;; references. We need some mechanism to do similar. -(defvar undo-equiv-table (make-hash-table :test 'eq #|:weakness t|#) - "Table mapping redo records to the corresponding undo one. -A redo record for undo-in-region maps to t. -A redo record for ordinary undo maps to the following (earlier) undo.") - -(defvar undo-in-region nil - "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.") - -(defvar undo-no-redo nil - "If t, `undo' doesn't go through redo entries.") - -(defvar pending-undo-list nil - "Within a run of consecutive undo commands, list remaining to be undone. -If t, we undid all the way to the end of it.") - -(defcommand undo ((&optional arg) - ;; XXX: what about the *? - :raw-prefix) - "Undo some previous changes. -Repeat this command to undo more changes. -A numeric argument serves as a repeat count. - -In Transient Mark mode when the mark is active, only undo changes within -the current region. Similarly, when not in Transient Mark mode, just \\[universal-argument] -as an argument limits undo to changes within the current region." - ;;(interactive "*P") - ;; Make last-command indicate for the next command that this was an undo. - ;; That way, another undo will undo more. - ;; If we get to the end of the undo history and get an error, - ;; another undo command will find the undo history empty - ;; and will get another error. To begin undoing the undos, - ;; you must type some other command. - (let ((modified (buffer-modified-p (current-buffer))) - (recent-save (recent-auto-save-p)) - message) - ;; If we get an error in undo-start, - ;; the next command should not be a "consecutive undo". - ;; So set `this-command' to something other than `undo'. - (setq *this-command* 'undo-start) - - (unless (and (eq *last-command* 'undo) - (or (eq pending-undo-list t) - ;; If something (a timer or filter?) changed the buffer - ;; since the previous command, don't continue the undo seq. - (let ((list (buffer-undo-list (current-buffer)))) - (while (eq (car list) nil) - (setq list (cdr list))) - ;; If the last undo record made was made by undo - ;; it shows nothing else happened in between. - (gethash list undo-equiv-table)))) - (message "guuuungh") - (setq undo-in-region - (if transient-mark-mode *mark-active* (and arg (not (numberp arg))))) - (if undo-in-region - (undo-start (region-beginning) (region-end)) - (undo-start)) - ;; get rid of initial undo boundary - (undo-more 1)) - ;; If we got this far, the next command should be a consecutive undo. - (setq *this-command* 'undo) - ;; Check to see whether we're hitting a redo record, and if - ;; so, ask the user whether she wants to skip the redo/undo pair. - (let ((equiv (gethash pending-undo-list undo-equiv-table))) - (or (eq (selected-window) (minibuffer-window)) - (setq message (if undo-in-region - (if equiv "Redo in region!" "Undo in region!") - (if equiv "Redo!" "Undo!")))) - (when (and (consp equiv) undo-no-redo) - ;; The equiv entry might point to another redo record if we have done - ;; undo-redo-undo-redo-... so skip to the very last equiv. - (while (let ((next (gethash equiv undo-equiv-table))) - (if next (setq equiv next)))) - (setq pending-undo-list equiv))) - (undo-more - (if (or transient-mark-mode (numberp arg)) - (prefix-numeric-value arg) - 1)) - ;; Record the fact that the just-generated undo records come from an - ;; undo operation--that is, they are redo records. - ;; In the ordinary case (not within a region), map the redo - ;; record to the following undos. - ;; I don't know how to do that in the undo-in-region case. - (setf (gethash (buffer-undo-list (current-buffer)) undo-equiv-table) - (if undo-in-region t pending-undo-list)) - ;; Don't specify a position in the undo record for the undo command. - ;; Instead, undoing this should move point to where the change is. - (let ((tail (buffer-undo-list (current-buffer))) - (prev nil)) - (message "its: ~s" tail) - (while (car tail) - (when (integerp (car tail)) - (let ((pos (car tail))) - (if prev - (setf (cdr prev) (cdr tail)) - (setf (buffer-undo-list (current-buffer)) (cdr tail))) - (setq tail (cdr tail)) - (while (car tail) - (if (eql pos (car tail)) - (if prev - (setf (cdr prev) (cdr tail)) - (setf (buffer-undo-list (current-buffer)) (cdr tail))) - (setq prev tail)) - (setq tail (cdr tail))) - (setq tail nil))) - (setq prev tail - tail (cdr tail)))) - ;; Record what the current undo list says, - ;; so the next command can tell if the buffer was modified in between. - (and modified (not (buffer-modified-p (current-buffer))) - (delete-auto-save-file-if-necessary recent-save)) - ;; Display a message announcing success. - (if message - (message message)))) - -(defcommand buffer-disable-undo ((&optional buffer)) - "Make BUFFER stop keeping undo information. -No argument or nil as argument means do this for the current buffer." - (with-current-buffer (if buffer (get-buffer buffer) (current-buffer)) - (setf (buffer-undo-list (current-buffer)) t))) - -(defcommand undo-only ((&optional arg) - ;; XXX what about * - :prefix) - "Undo some previous changes. -Repeat this command to undo more changes. -A numeric argument serves as a repeat count. -Contrary to `undo', this will not redo a previous undo." - ;;(interactive "*p") - (let ((undo-no-redo t)) (undo arg))) - -(defvar undo-in-progress nil - "Non-nil while performing an undo. -Some change-hooks test this variable to do something different.") - -(defun undo-more (n) - "Undo back N undo-boundaries beyond what was already undone recently. -Call `undo-start' to get ready to undo recent changes, -then call `undo-more' one or more times to undo them." - (or (listp pending-undo-list) - (error (concat "No further undo information" - (and transient-mark-mode *mark-active* - " for region")))) - (let ((undo-in-progress t)) - (setq pending-undo-list (primitive-undo n pending-undo-list)) - (if (null pending-undo-list) - (setq pending-undo-list t)))) - -;; Deep copy of a list -(defun undo-copy-list (list) - "Make a copy of undo list LIST." - (labels ((helper (elt) - (if (typep elt 'structure-object) - (copy-structure elt) - elt))) - (mapcar #'helper list))) - -(defun undo-start (&optional beg end) - "Set `pending-undo-list' to the front of the undo list. -The next call to `undo-more' will undo the most recently made change. -If BEG and END are specified, then only undo elements -that apply to text between BEG and END are used; other undo elements -are ignored. If BEG and END are nil, all undo elements are used." - (if (eq (buffer-undo-list (current-buffer)) t) - (error "No undo information in this buffer")) - (setq pending-undo-list - (if (and beg end (not (= beg end))) - (undo-make-selective-list (min beg end) (max beg end)) - (buffer-undo-list (current-buffer))))) - -(defvar undo-adjusted-markers) - -(defun undo-make-selective-list (start end) - "Return a list of undo elements for the region START to END. -The elements come from `buffer-undo-list', but we keep only -the elements inside this region, and discard those outside this region. -If we find an element that crosses an edge of this region, -we stop and ignore all further elements." - (let ((undo-list-copy (undo-copy-list (buffer-undo-list (current-buffer)))) - (undo-list (list nil)) - undo-adjusted-markers - some-rejected - undo-elt temp-undo-list delta) - (while undo-list-copy - (setq undo-elt (car undo-list-copy)) - (let ((keep-this - (cond ((typep undo-elt 'undo-entry-modified) ;;(and (consp undo-elt) (eq (car undo-elt) t)) - ;; This is a "was unmodified" element. - ;; Keep it if we have kept everything thus far. - (not some-rejected)) - (t - (undo-elt-in-region undo-elt start end))))) - (if keep-this - (progn - (setq end (+ end (cdr (undo-delta undo-elt)))) - ;; Don't put two nils together in the list - (if (not (and (eq (car undo-list) nil) - (eq undo-elt nil))) - (setq undo-list (cons undo-elt undo-list)))) - (if (undo-elt-crosses-region undo-elt start end) - (setq undo-list-copy nil) - (progn - (setq some-rejected t) - (setq temp-undo-list (cdr undo-list-copy)) - (setq delta (undo-delta undo-elt)) - - (when (/= (cdr delta) 0) - (let ((position (car delta)) - (offset (cdr delta))) - - ;; Loop down the earlier events adjusting their buffer - ;; positions to reflect the fact that a change to the buffer - ;; isn't being undone. We only need to process those element - ;; types which undo-elt-in-region will return as being in - ;; the region since only those types can ever get into the - ;; output - - (dolist (undo-elt temp-undo-list) - (cond ((integerp undo-elt) - (if (>= undo-elt position) - (setf (car temp-undo-list) (- undo-elt offset)))) - ;;((atom undo-elt) nil) - ((typep undo-elt 'undo-entry-delete) ;(stringp (car undo-elt)) - ;; (TEXT . POSITION) - (let ((text-pos (abs (undo-entry-delete-position undo-elt))) - (point-at-end (< (undo-entry-delete-position undo-elt) 0 ))) - (if (>= text-pos position) - (setf (undo-entry-delete-position undo-elt) (* (if point-at-end -1 1) - (- text-pos offset)))))) - ((typep undo-elt 'undo-entry-insertion) ;(integerp (car undo-elt)) - ;; (BEGIN . END) - (when (>= (undo-entry-insertion-beg undo-elt) position) - (setf (undo-entry-insertion-beg undo-elt) (- (undo-entry-insertion-beg undo-elt) offset)) - (setf (undo-entry-insertion-end undo-elt) (- (undo-entry-insertion-end undo-elt) offset)))) - ((typep undo-elt 'undo-entry-property) ;(null (car undo-elt)) - ;; (nil PROPERTY VALUE BEG . END) - (when (>= (undo-entry-property-beg undo-elt) position) - (setf (undo-entry-property-beg undo-elt) (- (undo-entry-property-beg undo-elt) offset)) - (setf (undo-entry-property-end undo-elt) (- (undo-entry-property-end undo-elt) offset)))))))))))) - (setq undo-list-copy (cdr undo-list-copy))) - (nreverse undo-list))) - -(defun undo-elt-in-region (undo-elt start end) - "Determine whether UNDO-ELT falls inside the region START ... END. -If it crosses the edge, we return nil." - (cond ((integerp undo-elt) - (and (>= undo-elt start) - (<= undo-elt end))) - ((eq undo-elt nil) - t) -;; ((atom undo-elt) -;; nil) - ((typep undo-elt 'undo-entry-delete) ; (stringp (car undo-elt)) - ;; (TEXT . POSITION) - (and (>= (abs (undo-entry-delete-position undo-elt)) start) - (< (abs (undo-entry-delete-position undo-elt)) end))) - ((typep undo-elt 'undo-entry-marker) ;(and (consp undo-elt) (markerp (car undo-elt))) - ;; This is a marker-adjustment element (MARKER . ADJUSTMENT). - ;; See if MARKER is inside the region. - (let ((alist-elt (assq (undo-entry-marker-marker undo-elt) undo-adjusted-markers))) - (unless alist-elt - (setq alist-elt (make-undo-entry-marker :marker (undo-entry-marker-marker undo-elt) - :distance (marker-position (undo-entry-marker-marker undo-elt)))) - (setq undo-adjusted-markers - (cons alist-elt undo-adjusted-markers))) - (and (undo-entry-marker-distance alist-elt) ;(cdr alist-elt) - (>= (undo-entry-marker-distance alist-elt) start) - (<= (undo-entry-marker-distance alist-elt) end)))) - ((typep undo-elt 'undo-entry-property) ;(null (car undo-elt)) - ;; (nil PROPERTY VALUE BEG . END) - (and (>= (undo-entry-property-beg undo-elt) start) - (<= (undo-entry-property-end undo-elt) end))) - ((typep undo-elt 'undo-entry-insertion) ;(integerp (car undo-elt)) - ;; (BEGIN . END) - (and (>= (undo-entry-insertion-beg undo-elt) start) - (<= (undo-entry-insertion-end undo-elt) end))))) - -(defun undo-elt-crosses-region (undo-elt start end) - "Test whether UNDO-ELT crosses one edge of that region START ... END. -This assumes we have already decided that UNDO-ELT -is not *inside* the region START...END." - (cond ;; (atom undo-elt) nil) - ((typep undo-elt 'undo-entry-property) ;(null (car undo-elt)) - ;; (nil PROPERTY VALUE BEG . END) - ;;(let ((tail (nthcdr 3 undo-elt))) - (not (or (< (undo-entry-property-beg undo-elt) end) - (> (undo-entry-property-end undo-elt) start)))) - ((typep undo-elt 'undo-entry-insertion) ;(integerp (car undo-elt)) - ;; (BEGIN . END) - (not (or (< (undo-entry-insertion-beg undo-elt) end) - (> (undo-entry-insertion-end undo-elt) start)))))) - -;; Return the first affected buffer position and the delta for an undo element -;; delta is defined as the change in subsequent buffer positions if we *did* -;; the undo. -(defun undo-delta (undo-elt) - (cond ((typep undo-elt 'undo-entry-delete) ;(stringp (car undo-elt)) - ;; (TEXT . POSITION) - (cons (abs (undo-entry-delete-position undo-elt)) (length (undo-entry-delete-text undo-elt)))) - ((typep undo-elt 'undo-entry-insertion) ;(integerp (car undo-elt)) - ;; (BEGIN . END) - (cons (undo-entry-insertion-beg undo-elt) (- (undo-entry-insertion-beg undo-elt) (undo-entry-insertion-end undo-elt)))) - (t - '(0 . 0)))) - -(defcustom undo-ask-before-discard nil - "If non-nil ask about discarding undo info for the current command. -Normally, Emacs discards the undo info for the current command if -it exceeds `undo-outer-limit'. But if you set this option -non-nil, it asks in the echo area whether to discard the info. -If you answer no, there a slight risk that Emacs might crash, so -only do it if you really want to undo the command. - -This option is mainly intended for debugging. You have to be -careful if you use it for other purposes. Garbage collection is -inhibited while the question is asked, meaning that Emacs might -leak memory. So you should make sure that you do not wait -excessively long before answering the question." - :type 'boolean - :group 'undo - :version "22.1") - -(define-buffer-local *undo-extra-outer-limit* 'undo-outer-limit-truncate ;;nil - "If non-nil, an extra level of size that's ok in an undo item. -We don't ask the user about truncating the undo list until the -current item gets bigger than this amount. - -This variable only matters if `undo-ask-before-discard' is non-nil.") - -;;(make-variable-buffer-local 'undo-extra-outer-limit) - -;; When the first undo batch in an undo list is longer than -;; undo-outer-limit, this function gets called to warn the user that -;; the undo info for the current command was discarded. Garbage -;; collection is inhibited around the call, so it had better not do a -;; lot of consing. -;;(setq undo-outer-limit-function 'undo-outer-limit-truncate) -(defun undo-outer-limit-truncate (size) - (if undo-ask-before-discard - (when (or (null *undo-extra-outer-limit*) - (> size *undo-extra-outer-limit*)) - ;; Don't ask the question again unless it gets even bigger. - ;; This applies, in particular, if the user quits from the question. - ;; Such a quit quits out of GC, but something else will call GC - ;; again momentarily. It will call this function again, - ;; but we don't want to ask the question again. - (setf *undo-extra-outer-limit* (+ size 50000)) - (if (let (*use-dialog-box* *track-mouse* *executing-kbd-macro* ) - (yes-or-no-p (format nil "Buffer `~a' undo info is ~d bytes long; discard it? " - (buffer-name (current-buffer)) size))) - (progn (setf (buffer-undo-list (current-buffer)) nil) - (setf *undo-extra-outer-limit* nil) - t) - nil)) - (progn - (display-warning '(undo discard-info) - (concat - (format nil "Buffer `~a' undo info was ~d bytes long.~%" - (buffer-name (current-buffer)) size) - "The undo info was discarded because it exceeded \ -`undo-outer-limit'. - -This is normal if you executed a command that made a huge change -to the buffer. In that case, to prevent similar problems in the -future, set `undo-outer-limit' to a value that is large enough to -cover the maximum size of normal changes you expect a single -command to make, but not so large that it might exceed the -maximum memory allotted to Emacs. - -If you did not execute any such command, the situation is -probably due to a bug and you should report it. - -You can disable the popping up of this buffer by adding the entry -\(undo discard-info) to the user option `warning-suppress-types'. -") - :warning) - (setf (buffer-undo-list (current-buffer)) nil) - t))) - +;;; undo code from undo.c + +(in-package "LICE") + +(defvar *last-undo-buffer* nil + "Last buffer for which undo information was recorded.") + +;; FIXME: a global used in these functions is probably bad wrt concurrency +(defvar *pending-boundary* nil + "The first time a command records something for undo. +it also allocates the undo-boundary object +which will be added to the list at the end of the command. +This ensures we can't run out of space while trying to make +an undo-boundary.") + +(defun undo-boundary (&optional (buffer (current-buffer))) + "Mark a boundary between units of undo. +An undo command will stop at this point, +but another undo command will undo to the previous boundary." + (when (eq (buffer-undo-list buffer) t) + (return-from undo-boundary nil)) + (when (car (buffer-undo-list buffer)) + ;; One way or another, cons nil onto the front of the undo list. + (if *pending-boundary* + ;; If we have preallocated the cons cell to use here, use that one. ; why the little dance? -sabetts + (setf (cdr *pending-boundary*) (buffer-undo-list buffer) + (buffer-undo-list buffer) *pending-boundary* + *pending-boundary* nil) + (push nil (buffer-undo-list buffer))) + nil)) + +(defun ensure-pending-boundary () + "Allocate a cons cell to be the undo boundary after this command." + (when (null *pending-boundary*) + (setf *pending-boundary* (cons nil nil)))) + +(defun ensure-last-undo-buffer (&optional (buffer (current-buffer))) + (unless (eq buffer *last-undo-buffer*) + (undo-boundary buffer)) + (setf *last-undo-buffer* buffer)) + +(defun record-point (pt &optional (buffer (current-buffer))) + "Record point as it was at beginning of this command (if necessary) +And prepare the undo info for recording a change. +PT is the position of point that will naturally occur as a result of the +undo record that will be added just after this command terminates." + (let (at-boundary) + (ensure-pending-boundary) + (ensure-last-undo-buffer buffer) + (if (consp (buffer-undo-list buffer)) + ;; Set AT_BOUNDARY to 1 only when we have nothing other than + ;; marker adjustment before undo boundary. + (setf at-boundary (loop + for elt in (buffer-undo-list buffer) + while (typep elt 'undo-entry-marker) + finally (return (null elt)))) + (setf at-boundary t)) + ;; FIXME + ;; if (MODIFF <= SAVE_MODIFF) + ;; record_first_change (); + (when (and at-boundary + ;; If we're called from batch mode, this could be nil. + (eq buffer *last-point-position-buffer*)) + ;; If we have switched windows, use the point value + ;; from the window we are in. + (unless (eq *last-point-position-window* (selected-window)) + (setf *last-point-position* (marker-position (window-point (selected-window))))) + (when (/= *last-point-position* pt) + (push *last-point-position* (buffer-undo-list buffer)))))) + +(defun record-insert (beg length &optional (buffer (current-buffer))) + "Record an insertion that just happened or is about to happen, for +LENGTH characters at position BEG. (It is possible to record an +insertion before or after the fact because we don't need to record +the contents.)" + (when (eq (buffer-undo-list buffer) t) + (return-from record-insert nil)) + (record-point beg buffer) + ;; If this is following another insertion and consecutive with it + ;; in the buffer, combine the two. + (when (consp (buffer-undo-list buffer)) + (let ((elt (car (buffer-undo-list buffer)))) + (when (and (typep elt 'undo-entry-insertion) + (= (undo-entry-insertion-end elt) beg)) + (setf (undo-entry-insertion-end elt) (+ beg length)) + (return-from record-insert nil)))) + + (push (make-undo-entry-insertion :beg beg :end (+ beg length)) (buffer-undo-list buffer))) + +(defun record-delete (beg string &optional (buffer (current-buffer))) + "Record that a deletion is about to take place, of the +characters in STRING, at location BEG." + (when (eq (buffer-undo-list buffer) t) + (return-from record-delete nil)) + (if (= (point) (+ beg (length string))) + (progn + (setf beg (- beg)) + (record-point (point))) + (record-point beg)) + (push (make-undo-entry-delete :position beg :text string) + (buffer-undo-list buffer))) + +(defun record-marker-adjustment (marker adjustment &optional (buffer (current-buffer))) + "Record the fact that MARKER is about to be adjusted by ADJUSTMENT. +This is done only when a marker points within text being deleted, +because that's the only case where an automatic marker adjustment +won't be inverted automatically by undoing the buffer modification." + (when (eq (buffer-undo-list buffer) t) + (return-from record-marker-adjustment nil)) + (unless *pending-boundary* + (setf *pending-boundary* (cons nil nil))) + (unless (eq buffer *last-undo-buffer*) + (undo-boundary buffer)) + (setf *last-undo-buffer* buffer) + (push (make-undo-entry-marker :marker marker :adjustment adjustment) + (buffer-undo-list buffer))) + +(defun record-change (beg length &optional (buffer (current-buffer))) + "Record that a replacement is about to take place, +for LENGTH characters at location BEG. +The replacement must not change the number of characters." + (record-delete beg (buffer-substring beg (+ beg length) buffer)) + (record-insert beg length)) + +(defun record-first-change (&optional (buffer (current-buffer))) + "Record that an unmodified buffer is about to be changed. +Record the file modification date so that when undoing this entry +we can tell whether it is obsolete because the file was saved again." + (when (eq (buffer-undo-list buffer) t) + (return-from record-first-change nil)) + + (unless (eq buffer *last-undo-buffer*) + (undo-boundary buffer)) + (setf *last-undo-buffer* buffer) + + ;; FIXME + ;; if (base_buffer->base_buffer) + ;; base_buffer = base_buffer->base_buffer; + + ;; FIXME: implement modtime + (push (make-undo-entry-modified :time nil) + (buffer-undo-list buffer))) + +(defun record-property-change (beg length prop value buffer) + "Record a change in property PROP (whose old value was VAL) +for LENGTH characters starting at position BEG in BUFFER." + (let (boundary) + (when (eq (buffer-undo-list buffer) t) + (return-from record-property-change nil)) + + (ensure-pending-boundary) + (unless (eq buffer *last-undo-buffer*) + (setf boundary t)) + (setf *last-undo-buffer* buffer) + (when boundary + (undo-boundary buffer)) + ;; FIXME + ;; if (MODIFF <= SAVE_MODIFF) + ;; record_first_change (); + + (push (make-undo-entry-property :prop prop :value value :beg beg :end (+ beg length)) + (buffer-undo-list buffer)))) + +(defgeneric primitive-undo-elt (undo-elt) + ) + +(defmethod primitive-undo-elt ((elt integer)) + "Handle an integer by setting point to that value." + (set-point (clip-to-bounds (begv) elt (zv)))) + +(defmethod primitive-undo-elt ((elt undo-entry-insertion)) + (when (or (< (undo-entry-insertion-beg elt) (begv)) + (> (undo-entry-insertion-end elt) (zv))) + (error "Changes to be undone are outside visible portion of buffer")) + (goto-char (undo-entry-insertion-beg elt)) + (delete-region (undo-entry-insertion-beg elt) + (undo-entry-insertion-end elt))) + +(defmethod primitive-undo-elt ((elt undo-entry-delete)) + (let ((pos (undo-entry-delete-position elt)) + (text (undo-entry-delete-text elt))) + (if (minusp pos) + (progn + (when (or (< (- pos) (begv)) + (> (- pos) (zv))) + (error "Changes to be undone are outside visible portion of buffer")) + (set-point (- pos)) + (insert text)) + (progn + (when (or (< pos (begv)) + (> pos (zv))) + (error "Changes to be undone are outside visible portion of buffer")) + (set-point pos) + (insert text) + (set-point pos))))) + +(defmethod primitive-undo-elt ((undo-elt undo-entry-modified)) + (error "unimplented")) + +(defmethod primitive-undo-elt ((elt undo-entry-property)) + (put-text-property (undo-entry-property-beg elt) + (undo-entry-property-end elt) + (undo-entry-property-prop elt) + (undo-entry-property-value elt) + nil)) + +(defmethod primitive-undo-elt ((undo-elt undo-entry-apply)) + (error "unimplented")) + +(defmethod primitive-undo-elt ((undo-elt undo-entry-selective)) + (error "unimplented")) + +(defmethod primitive-undo-elt ((elt undo-entry-marker)) + (let ((marker (undo-entry-marker-marker elt))) + (when (marker-buffer marker) + (set-marker marker (- (marker-position marker) + (undo-entry-marker-distance elt)) + (marker-buffer marker))))) + +(defun primitive-undo (n list) + "Undo N records from the front of the list LIST. +Return what remains of the list." + (check-type n integer) + (let ( ;; Don't let `intangible' properties interfere with undo. + (*inhibit-point-motion-hooks* t) + ;; In a writable buffer, enable undoing read-only text that is so + ;; because of text properties. + (*inhibit-read-only* t)) + (dotimes (arg n) + (while (consp list) + (let ((elt (pop list))) + ;; Exit inner loop at undo boundary. + (when (null elt) + (return nil)) + (primitive-undo-elt elt)))) + ;; Make sure an apply entry produces at least one undo entry, + ;; so the test in `undo' for continuing an undo series + ;; will work right. + list)) diff --git a/window.lisp b/window.lisp index 29c6742..500621f 100644 --- a/window.lisp +++ b/window.lisp @@ -1,4 +1,4 @@ -(in-package :lice) +(in-package "LICE") (defvar *next-screen-context-lines* 2 "Number of lines of continuity when scrolling by screenfuls.") @@ -9,6 +9,17 @@ (defvar *window-min-width* 10 "Delete any window less than this wide.") +(defmacro check-live-window (win) + "This macro rejects windows on the interior of the window tree as +\"dead\", which is what we want; this is an argument-checking macro, and +the user should never get access to interior windows. + +A window of any sort, leaf or interior, is dead iff the buffer, +vchild, and hchild members are all nil." + `(and + (check-type ,win window) + (not (null (window-buffer ,win))))) + ;; we just want a fast and easy dumping area for data. start and end ;; are inclusive. (defstruct cache-item @@ -21,56 +32,12 @@ ;; :fill-pointer 0) ()) -;; start and end are inclusive and are buffer points -(defclass line-cache () - ((start :type integer :initform 0 :initarg :start :accessor lc-start) - (end :type integer :initform 0 :initarg :end :accessor lc-end) - (valid :type boolean :initform nil :initarg :valid :accessor lc-valid) - (cache :type list ;;(array cache-item 1) - :initform nil ;; (make-array 0 :element-type 'cache-item -;; :adjustable t -;; :fill-pointer 0) - :initarg :cache :accessor lc-cache))) - (defun item-in-cache (window n) "Return the Nth item in the cache or NIL if it doesn't exist." (elt (lc-cache (window-cache window)) n)) ;; (when (< n (length (lc-cache (window-cache window)))) ;; (aref (lc-cache (window-cache window)) n))) -(defclass window () - ((frame :initarg :frame :accessor window-frame) - (x :type integer :initarg :x :accessor window-x) - (y :type integer :initarg :y :accessor window-y) - (w :type integer :initarg :w :documentation - "The width of the window's contents.") - (h :type integer :initarg :h :documentation - "The total height of the window, including the mode-line.") - (seperator :type boolean :initform nil :accessor window-seperator :documentation - "T when the window is to draw a vertical seperator. used in horizontal splits.") - (line-state :type (array integer 1) :initarg :line-state :accessor window-line-state) - (cache :type line-cache :initarg :cache :accessor window-cache) - ;; Indices into cache (inclusive) that describe the range of the - ;; cache that will be displayed. - (top-line :type integer :initarg :top-line :accessor window-top-line) - (bottom-line :type integer :initarg :bottom-line :accessor window-bottom-line) - (point-col :type integer :initarg :point-col :accessor window-point-col) - (point-line :type integer :initarg :point-line :accessor window-point-line) - ;; The rest refer to points in the buffer - (buffer :type buffer :initarg :buffer :accessor window-buffer) - (bpoint :type marker :initarg :bpoint :accessor window-bpoint :documentation - "A marker marking where in the text the window point is.") - (top :type marker :initarg :top :accessor window-top :documentation - "The point in buffer that is the first character displayed in the window") - (bottom :type marker :initarg :bottom :accessor window-bottom :documentation - "The point in buffer that is the last character displayed -in the window. This should only be used if bottom-valid is T.") - (bottom-valid :type boolean :initform nil :accessor window-bottom-valid :documentation - "When this is T then bottom should be used to -calculate the visible contents of the window. This is used when -scrolling up (towards the beginning of the buffer).")) - (:documentation "A Lice Window.")) - ;; (defun update-window-display-arrays (window) ;; "Used to update the window display structures for window splits." ;; (let* ((rows (window-height window t)) @@ -109,7 +76,7 @@ TYPE isn't used yet. it's just there for hype." :bpoint bpoint :point-col 0 :point-line 0))) - (set-marker bpoint (point buffer) buffer) + (set-marker bpoint (pt buffer) buffer) (set-marker top (begv buffer) buffer) (set-marker bottom (begv buffer) buffer) w)) @@ -125,7 +92,7 @@ TYPE isn't used yet. it's just there for hype." included in the height." ;; if the mode-line is nil, then there is no modeline. (if (or include-mode-line - (null (buffer-mode-line (window-buffer w)))) + (null (buffer-local '*mode-line-format* (window-buffer w)))) (slot-value w 'h) (1- (slot-value w 'h)))) @@ -138,14 +105,10 @@ for horizontal splits, is not included in the width." (slot-value w 'w) (1- (slot-value w 'w)))) -(defun get-current-window (&optional (frame (selected-frame))) - "Return the current window in the current frame. If FRAME is -specified, use that frame instead." - (frame-current-window frame)) - (defun selected-window () "Return the window that the cursor now appears in and commands apply to." - (get-current-window)) + (frame-selected-window (selected-frame))) +;; *selected-window*) (defun set-window-buffer (window buffer &optional keep-margins) "Make WINDOW display BUFFER as its contents. @@ -595,12 +558,12 @@ above WINDOW-POINT, or as many as possible if we hit the top of the window." (defun window-point (&optional window) "Return current value of point in WINDOW. For a nonselected window, this is the value point would have if that window were selected." - (if (eq window (get-current-window)) - (point (window-buffer window)) + (if (eq window (selected-window)) + (pt (window-buffer window)) (marker-position (window-bpoint window)))) (defun set-window-point (window pos) - (let ((mark (if (eq window (get-current-window)) + (let ((mark (if (eq window (selected-window)) (buffer-point (window-buffer window)) (window-bpoint window)))) (if (and (<= pos (buffer-max (window-buffer window))) @@ -668,7 +631,7 @@ LINES many lines, moving the window point to be visible." (defun window-save-point (window) "Save WINDOW's buffer's point to WINDOW-BPOINT." - (setf (marker-position (window-bpoint window)) (point (window-buffer window)))) + (setf (marker-position (window-bpoint window)) (pt (window-buffer window)))) (defun window-restore-point (window) "Restore the WINDOW's buffer's point from WINDOW-BPOINT." @@ -676,9 +639,22 @@ LINES many lines, moving the window point to be visible." (setf (marker-position (buffer-point (window-buffer window))) (marker-position (window-bpoint window)))) +(defun window-tree-find-if (fn tree &optional minibuf) + "depth first search the tree. Return the element that satisfies FN." + (cond ((listp tree) + (loop for i in tree + thereis (window-tree-find-if fn i minibuf))) + ((typep tree 'minibuffer-window) + (when (and minibuf + (funcall fn tree)) + tree)) + (t + (when (funcall fn tree) + tree)))) + (defcommand delete-other-windows () (let* ((frame (selected-frame)) - (cw (get-current-window)) + (cw (selected-window)) (mb (window-tree-find-if (lambda (w) (typep w 'minibuffer-window)) (frame-window-tree frame) @@ -711,7 +687,7 @@ LINES many lines, moving the window point to be visible." (typep (frame-window-tree (window-frame window)) 'window)) (error "Attempt to delete minibuffer or sole ordinary window"))) -(defun pos-visible-in-window-p (&optional (pos (point)) (window (selected-window)) partially) +(defun pos-visible-in-window-p (&optional (pos (pt)) (window (selected-window)) partially) "Return non-nil if position POS is currently on the frame in WINDOW. Return nil if that position is scrolled vertically out of view. If a character is only partially visible, nil is returned, unless the @@ -733,5 +709,258 @@ display row, and VPOS is the row number (0-based) containing POS." ;; FIXME: horizontal scrolling. and all the partial stuff aint there (or (< pos (marker-position (window-top window))) (> pos (marker-position (window-bottom window))))) - + +(defun select-window (window &optional norecord) + "Select WINDOW. Most editing will apply to WINDOW's buffer. +If WINDOW is not already selected, also make WINDOW's buffer current. +Also make WINDOW the frame's selected window. +Optional second arg NORECORD non-nil means +do not put this buffer at the front of the list of recently selected ones. + +**Note that the main editor command loop +**selects the buffer of the selected window before each command." + (declare (ignore norecord)) + (check-live-window window) + (when (eq window (selected-window)) + (return-from select-window window)) + + (window-save-point (selected-window)) + (setf *selected-window* window) + (let ((sf (selected-frame))) + (if (eq sf (window-frame window)) + (progn + (setf (frame-selected-window (window-frame window)) window) + ;; (select-frame (window-frame window)) + ) + (setf (frame-selected-window sf) window)) + ;; FIXME: get NORECORD working + (set-buffer (window-buffer window)) + (window-restore-point window) + window)) + +(defun replace-window-in-frame-tree (window new) + (labels ((doit (tree window new) + (let ((p (position window tree))) + (if p + (setf (nth p tree) new) + (loop for w in tree + until (and (listp w) + (doit w window new))))))) + (doit (frame-window-tree (window-frame window)) + window + new))) + +(defun split-window (&optional (window (selected-window)) size horflag) + (when (typep window 'minibuffer-window) + (error "Attempt to split minibuffer window")) + (when (null size) + (setf size (if horflag + (ceiling (window-width window t) 2) + (ceiling (window-height window t) 2)))) + (let (new) + (if horflag + (progn + (when (< size *window-min-width*) + (error "Window width ~a too small (after splitting)" size)) + ;; will the other window be too big? + (when (> (+ size *window-min-width*) + (window-width window t)) + (error "Window width ~a too small (after splitting)" (- (window-width window t) size))) + (setf new (make-window :x (+ (window-x window) size) + :y (window-y window) + :cols (- (window-width window t) size) + :rows (window-height window t) + :buffer (window-buffer window) + :frame (window-frame window)) + (window-seperator new) (window-seperator window) + (window-seperator window) t + (slot-value window 'w) size) + ;;(update-window-display-arrays window) + ) + (progn + (when (< size *window-min-height*) + (error "Window height ~a too small (after splitting)" size)) + ;; will the other window be too big? + (when (> (+ size *window-min-height*) + (window-height window t)) + (error "Window width ~a too small (after splitting)" (- (window-height window t) size))) + (setf new (make-window :x (window-x window) + :y (+ (window-y window) size) + :cols (window-width window t) + :rows (- (window-height window t) size) + :buffer (window-buffer window) + :frame (window-frame window)) + (window-seperator new) (window-seperator window) + (slot-value window 'h) size) + ;;(update-window-display-arrays window) + )) + (replace-window-in-frame-tree window (list window new)) + new)) + +(defun next-window (window &optional minibuf) + "Return next window after WINDOW in canonical ordering of windows. +FIXME: make this the same as Emacs' next-window." + (let* ((frame (window-frame window)) + (tree (frame-window-tree frame)) + bit + ;; when we find WINDOW, set BIT to T and return the next window. + (w (window-tree-find-if (lambda (w) + (cond (bit w) + ((eq w window) + (setf bit t) + nil))) + tree + (and minibuf (> (frame-minibuffers-active frame) 0))))) + ;; if we didn't find the next one, maybe it's the first one + (if (not w) + (let ((other (window-tree-find-if #'identity tree))) + (unless (eq window other) + other)) + w))) + +(defun previous-window (&optional window minibuf all-frames) + "Return the window preceding WINDOW in canonical ordering of windows. +If omitted, WINDOW defaults to the selected window. + +Optional second arg MINIBUF t means count the minibuffer window even +if not active. MINIBUF nil or omitted means count the minibuffer iff +it is active. MINIBUF neither t nor nil means not to count the +minibuffer even if it is active. + +Several frames may share a single minibuffer; if the minibuffer +counts, all windows on all frames that share that minibuffer count +too. Therefore, `previous-window' can be used to iterate through +the set of windows even when the minibuffer is on another frame. If +the minibuffer does not count, only windows from WINDOW's frame count + +Optional third arg ALL-FRAMES t means include windows on all frames. +ALL-FRAMES nil or omitted means cycle within the frames as specified +above. ALL-FRAMES = `visible' means include windows on all visible frames. +ALL-FRAMES = 0 means include windows on all visible and iconified frames. +If ALL-FRAMES is a frame, restrict search to windows on that frame. +Anything else means restrict to WINDOW's frame. + +If you use consistent values for MINIBUF and ALL-FRAMES, you can use +`previous-window' to iterate through the entire cycle of acceptable +windows, eventually ending up back at the window you started with. +`next-window' traverses the same cycle, in the reverse order." + (declare (ignore window minibuf all-frames)) + (error "unimplemented")) + +(defcommand other-window ((arg &optional all-frames) + :prefix) + "Select the ARG'th different window on this frame. +All windows on current frame are arranged in a cyclic order. +This command selects the window ARG steps away in that order. +A negative ARG moves in the opposite order. The optional second +argument ALL-FRAMES has the same meaning as in `next-window', which see." + (declare (ignore all-frames)) + (check-type arg number) + (let ((w (cond + ((plusp arg) + (loop + for i from 1 to arg + for w = (next-window (selected-window) t) then (next-window w t) + finally (return w))) + ((minusp arg) + (loop + for i from arg downto 1 + for w = (previous-window (selected-window) t) then (previous-window w t) + finally (return w))) + (t (selected-window))))) + (when w + (select-window w)))) + +(defun display-buffer (buffer &optional not-this-window frame) + "Make BUFFER appear in some window but don't select it. +BUFFER can be a buffer or a buffer name. +If BUFFER is shown already in some window, just use that one, +unless the window is the selected window and the optional second +argument NOT-THIS-WINDOW is non-nil (interactively, with prefix arg). +**If `pop-up-frames' is non-nil, make a new frame if no window shows BUFFER. +**Returns the window displaying BUFFER. +**If `display-buffer-reuse-frames' is non-nil, and another frame is currently +**displaying BUFFER, then simply raise that frame." + (declare (ignore frame)) + (setf buffer (get-buffer buffer)) + (let* ((cw (selected-window)) + (w (or (window-tree-find-if (lambda (w) + (and (not (and not-this-window + (eq w cw))) + (eq (window-buffer w) buffer))) + (frame-window-tree (selected-frame))) + (next-window cw) + (split-window cw)))) + (set-window-buffer w buffer) + (window-restore-point w) + w)) + +(defun other-buffer (&optional (buffer (current-buffer)) visible-ok frame) + "Return most recently selected buffer other than BUFFER. +Buffers not visible in windows are preferred to visible buffers, +unless optional second argument VISIBLE-OK is non-nil. +If the optional third argument FRAME is non-nil, use that frame's +buffer list instead of the selected frame's buffer list. +If no other buffer exists, the buffer `*scratch*' is returned. +If BUFFER is omitted or nil, some interesting buffer is returned." + (declare (ignore frame)) + ;; TODO: honour FRAME argument + (let* (vis + (match (loop for b in *buffer-list* + unless (or (eq b buffer) + (char= (char (buffer-name b) 0) #\Space)) + if (and (not visible-ok) + (get-buffer-window b)) + do (setf vis b) + else return b))) + (or match + vis + (get-buffer-create "*scratch*")))) + +(defcommand kill-buffer ((buffer) + (:buffer "Kill buffer: " (buffer-name (current-buffer)) t)) + "Kill the buffer BUFFER. +The argument may be a buffer or may be the name of a buffer. +defaults to the current buffer. + +Value is t if the buffer is actually killed, nil if user says no. + +The value of `kill-buffer-hook' (which may be local to that buffer), +if not void, is a list of functions to be called, with no arguments, +before the buffer is actually killed. The buffer to be killed is current +when the hook functions are called. + +Any processes that have this buffer as the `process-buffer' are killed +with SIGHUP." + (let* ((target (get-buffer buffer)) + (other (other-buffer target))) + (if target + (progn + ;; all windows carrying the buffer need a new buffer + (loop for w in (frame-window-list (selected-frame)) + do (when (eq (window-buffer w) target) + (set-window-buffer w other))) + (setf *buffer-list* (delete target *buffer-list*))) + (error "No such buffer ~a" buffer)))) + +(defun pop-to-buffer (buffer &optional other-window norecord) + "Select buffer BUFFER in some window, preferably a different one. +If `pop-up-windows' is non-nil, windows can be split to do this. +If optional second arg OTHER-WINDOW is non-nil, insist on finding another +window even if BUFFER is already visible in the selected window. +This uses the function `display-buffer' as a subroutine; see the documentation +of `display-buffer' for additional customization information. + +**Optional third arg NORECORD non-nil means +**do not put this buffer at the front of the list of recently selected ones." + (declare (ignore norecord)) + ;; FIXME: honour NORECORD + (setf buffer (if buffer + (or (get-buffer buffer) + (progn + (get-buffer-create buffer))) + ;; FIXME: (set-buffer-major-mode buffer) + (other-buffer (current-buffer)))) + (select-window (display-buffer buffer other-window))) + (provide :lice-0.1/window) diff --git a/wm.lisp b/wm.lisp index 558162d..dee73a1 100644 --- a/wm.lisp +++ b/wm.lisp @@ -1,6 +1,6 @@ ;;; window configuration code -(in-package :lice) +(in-package "LICE") (defstruct window-bk "A structure that stores the vital data needed to restore a window." @@ -25,7 +25,7 @@ :bpoint (copy-marker bpoint) :buffer buffer))) ;; record the current window - (when (eq window (frame-current-window frame)) + (when (eq window (frame-selected-window frame)) (setf cw bk)) bk))) (dup-tree (tree) @@ -66,7 +66,7 @@ (restore-tree (second tree))))))) (setf (frame-window-tree frame) (cons (restore-tree (frame-bk-window-tree configuration)) (cdr (frame-window-tree frame))) - (frame-current-window frame) cw) + (frame-selected-window frame) cw) (set-buffer (window-buffer cw))))) (defmacro save-window-excursion (&body body) diff --git a/wrappers.lisp b/wrappers.lisp index 0ce778e..15edfb4 100644 --- a/wrappers.lisp +++ b/wrappers.lisp @@ -4,7 +4,10 @@ ;;; To add support for a new CL implementation, an entry in each of ;;; these functions must be made for it. -(in-package :lice) +;; don't print the unable to optimize notes +#+sbcl (declaim (sb-ext:muffle-conditions sb-ext:compiler-note)) + +(in-package "LICE") ;;; Weak Pointers -- 2.11.4.GIT