From e770599c7cba643578c9b1b333f9b74d9e4a6cdb Mon Sep 17 00:00:00 2001 From: tailor Date: Mon, 5 Mar 2007 13:58:59 +0000 Subject: [PATCH] [lice @ undo + other fixes] --- buffer.lisp | 161 ++++++++++---- editfns.lisp | 3 + files.lisp | 45 +++- global.lisp | 6 + indent.lisp | 6 +- input.lisp | 17 +- lice.asd | 3 +- lisp-mode.lisp | 9 +- main.lisp | 15 +- recursive-edit.lisp | 2 + search.lisp | 67 +++++- simple.lisp | 131 +++++------ subprocesses.lisp | 2 +- subr.lisp | 2 +- textprop.lisp | 4 + undo.lisp | 622 ++++++++++++++++++++++++++++++++++++++++++++++++++++ window.lisp | 21 +- wm.lisp | 44 ++-- 18 files changed, 1005 insertions(+), 155 deletions(-) create mode 100644 undo.lisp diff --git a/buffer.lisp b/buffer.lisp index 680ee31..5887ca2 100644 --- a/buffer.lisp +++ b/buffer.lisp @@ -16,6 +16,13 @@ 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' +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)) @@ -36,7 +43,7 @@ This variable should never be set using `setq' or `setf'. Bind it with ;; 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) + (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 @@ -51,6 +58,24 @@ is displayed in a window.") (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) @@ -60,7 +85,50 @@ is displayed in a window.") (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) - (syntax-table :initform *standard-syntax-table* :accessor buffer-syntax-table)) + (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) @@ -115,7 +183,12 @@ If you set the marker not to point anywhere, the buffer will have no mark." 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 `make-buffer-local'." - `(make-buffer-local ,symbol ,default-value ,doc-string)) + `(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)) + (make-buffer-local ',symbol ,default-value ,doc-string))) (defun (setf buffer-local) (symbol value) "Set the value of the buffer local in the current buffer." @@ -126,15 +199,16 @@ docstring for them. there is also `make-buffer-local'." (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, return nil." +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*) - (when b - (buffer-local-binding-value v)))))) + (if b + (buffer-local-binding-value v) + (error "No binding for buffer-local ~s" symbol)))))) -(define-buffer-local :buffer-invisibility-spec nil +(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. @@ -144,7 +218,7 @@ 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 +(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. @@ -161,9 +235,12 @@ in a file, save the ^M as a newline.") ;;; 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)) + (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) @@ -179,26 +256,25 @@ in a file, save the ^M as a newline.") (defmethod ensure-number ((thing marker)) (marker-position thing)) -(defun copy-marker (marker &optional type) +(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'." - (declare (ignore type)) - (make-marker (if (numberp marker) - marker - (marker-position marker)) - (if (typep marker 'marker) - (marker-buffer marker) - (current-buffer)))) - -(defun make-marker (&optional position buffer) + (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." - (let ((m (make-instance 'marker))) - (when (and position buffer) - (set-marker m position buffer)) - m)) + (make-instance 'marker)) (defun unchain-marker (marker) (when (marker-buffer marker) @@ -226,6 +302,7 @@ at that position in the current 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)) @@ -240,6 +317,7 @@ at that position in the current buffer. (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)) @@ -523,7 +601,7 @@ before an intangible character, move to an ok place." (defmethod buffer-insert :after ((buf buffer) object) "Any object insertion modifies the buffer." (declare (ignore object)) - (setf (buffer-modified buf) t)) + (setf (buffer-modified-p buf) t)) (defmethod buffer-insert ((buf buffer) (char character)) "Insert a single character into buffer before point." @@ -534,6 +612,8 @@ before an intangible character, move to an ok place." (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 @@ -550,6 +630,8 @@ before an intangible character, move to an ok place." (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)) @@ -598,6 +680,7 @@ before the text." (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))) @@ -609,22 +692,24 @@ before the text." (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 buf) t) + (setf (buffer-modified-p buf) t) ;; debuggning (fill-gap buf)) (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 buf) t) + (buffer-modified-p buf) t) ;; debugging (fill-gap buf)) @@ -753,9 +838,9 @@ number of newlines found. START and LIMIT are inclusive." (lambda (buffer) (format nil "~C~C" ;; FIXME: add read-only stuff - (if (buffer-modified buffer) + (if (buffer-modified-p buffer) #\* #\-) - (if (buffer-modified buffer) + (if (buffer-modified-p buffer) #\* #\-))) " " (lambda (buffer) @@ -843,18 +928,17 @@ The value is never nil.")) ;;; +(defparameter *initial-scratch-message* ";; This buffer is for notes you don't want to save, and for Lisp evaluation. +;; If you want to create a file, visit that file with C-x C-f, +;; then enter the text in that file's own buffer.") + (defun make-default-buffers () "Called on startup. Create the default buffers, putting them in *buffer-list*." ;; for the side effect - (get-buffer-create "*messages*") - (let ((scratch (get-buffer-create "*scratch*"))) - (buffer-insert scratch ";; This buffer is for notes you don't want to save, and for Lisp evaluation. -;; If you want to create a file, visit that file with C-x C-f, -;; then enter the text in that file's own buffer.") - ;; FIXME: is this a hack? - (setf (buffer-modified scratch) nil) - (goto-char (point-min scratch) scratch))) + (let ((msg (get-buffer-create "*messages*"))) + (setf (buffer-undo-list msg) t)) + (get-buffer-create "*scratch*")) ;;; @@ -932,6 +1016,9 @@ If BUFFER is omitted or nil, some interesting buffer is returned." 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 @@ -1005,7 +1092,7 @@ means that other_buffer is more likely to choose a relevant buffer." "Return t if object is an editor buffer." (typep object 'buffer)) -(define-buffer-local :default-directory (truename "") +(define-buffer-local *default-directory* (truename "") "Name of default directory of current buffer. To interactively change the default directory, use command `cd'.") diff --git a/editfns.lisp b/editfns.lisp index 9fe7b7a..c1fa5dd 100644 --- a/editfns.lisp +++ b/editfns.lisp @@ -418,4 +418,7 @@ This function does not move point." (point)))) (constrain-to-field pt (point) (not (eql n 1)) t nil))) +(defun clip-to-bounds (lower num upper) + (max (min num upper) lower)) + (provide :lice-0.1/editfns) diff --git a/files.lisp b/files.lisp index 62c9f49..21be781 100644 --- a/files.lisp +++ b/files.lisp @@ -61,7 +61,7 @@ (defcommand save-buffer () (let ((buffer (current-buffer))) (when (buffer-file buffer) - (if (buffer-modified buffer) + (if (buffer-modified-p buffer) (with-open-file (out (buffer-file buffer) :direction :output :if-exists :overwrite @@ -74,7 +74,7 @@ (write-sequence (buffer-data buffer) out :start (gap-end buffer) :end (length (buffer-data buffer))) - (setf (buffer-modified buffer) nil) + (setf (buffer-modified-p buffer) nil) (message "Wrote ~a~%" (buffer-file (current-buffer)))) (message "(No changes need to be saved)"))))) @@ -95,4 +95,45 @@ "Load the Lisp file named FILE." (load file)) +;;; auto save + +(defun recent-auto-save-p () + "Return t if current buffer has been auto-saved recently. +More precisely, if it has been auto-saved since last read from or saved +in the visited file. If the buffer has no visited file, +then any auto-save counts as \"recent\"." + ;; FIXME: implement + nil) + +(defun set-buffer-auto-saved () +"Mark current buffer as auto-saved with its current text. +No auto-save file will be written until the buffer changes again." + (setf (buffer-auto-save-modified (current-buffer)) (buffer-modiff (current-buffer)))) + +;; FIXME: maybe this should be a slot in the buffer with the rest of the autosave slots +(define-buffer-local buffer-auto-save-file-name nil + "Name of file for auto-saving current buffer. +If it is nil, that means don't auto-save this buffer.") + +(defcustom *delete-auto-save-files* t + "Non-nil means delete auto-save file when a buffer is saved or killed. + +Note that the auto-save file will not be deleted if the buffer is killed +when it has unsaved changes." + :type 'boolean + :group 'auto-save) + +(defun delete-auto-save-file-if-necessary (&optional force) + "Delete auto-save file for current buffer if `delete-auto-save-files' is t. +Normally delete only if the file was written by this Emacs since +the last real save, but optional arg FORCE non-nil means delete anyway." + (and buffer-auto-save-file-name *delete-auto-save-files* + (not (string= (buffer-file (current-buffer)) buffer-auto-save-file-name)) + (or force (recent-auto-save-p)) + (progn + (handler-case + (delete-file buffer-auto-save-file-name) + (file-error () nil)) + (set-buffer-auto-saved)))) + (provide :lice-0.1/files) diff --git a/global.lisp b/global.lisp index 65d379b..670c813 100644 --- a/global.lisp +++ b/global.lisp @@ -105,5 +105,11 @@ before making `inhibit-quit' nil.") (defvar *quit-flag* nil "Set to T when the user hit the quit key") +;; XXX: get rid of this function and all callers +(defun assq (key list) + "Return non-nil if key is `eq' to the car of an element of list. +The value is actually the first element of list whose car is key. +Elements of list that are not conses are ignored." + (assoc prop (remove-if 'listp list))) (provide :lice-0.1/global) diff --git a/indent.lisp b/indent.lisp index 85aca84..a882dd6 100644 --- a/indent.lisp +++ b/indent.lisp @@ -193,16 +193,16 @@ column to indent to; if it is nil, use one of the three methods above." (message "guuh ~s ~s" column *prefix-arg*) (if (null column) - (if (buffer-local :fill-prefix) + (if *fill-prefix* (save-excursion (goto-char end) (setq end (point-marker)) (goto-char start) - (let ((regexp (regexp-quote (buffer-local :fill-prefix)))) + (let ((regexp (regexp-quote *fill-prefix*))) (while (< (point) (marker-position end)) (or (looking-at regexp) (and (bolp) (eolp)) - (insert (buffer-local :fill-prefix))) + (insert *fill-prefix*)) (forward-line 1)))) (if *indent-region-function* (funcall *indent-region-function* start end) diff --git a/input.lisp b/input.lisp index ea2e075..e0254b2 100644 --- a/input.lisp +++ b/input.lisp @@ -56,6 +56,15 @@ operation (by pressing C-g, for instance).")) (apply #',name ,tmp)))))))) +(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.") @@ -149,7 +158,11 @@ The value is a list of KEYs." ) (setf *last-command* *this-command* ;; reset command keys, since the command is over. - *this-command-keys* nil))) + *this-command-keys* nil) + ;; handle undo + (undo-boundary) + +)) ;;; events @@ -419,6 +432,8 @@ more." (define-key kmap (make-instance 'key :char #\\ :control t :meta t) 'indent-region) (define-key kmap (make-instance 'key :char #\a :control t :meta t) 'beginning-of-defun) (define-key kmap (make-instance 'key :char #\e :control t :meta t) 'end-of-defun) + (define-key kmap (make-instance 'key :char #\_ :control t) 'undo) + (define-key kmap (make-instance 'key :char #\/ :control t) 'undo) (define-key kmap (make-instance 'key :char #\x :control t) ctl-x-prefix) (define-key kmap (make-instance 'key :char #\c :control t) ctl-c-prefix) (define-key kmap (make-instance 'key :char #\h :control t) ctl-h-prefix) diff --git a/lice.asd b/lice.asd index f3a542d..eb066da 100644 --- a/lice.asd +++ b/lice.asd @@ -26,7 +26,8 @@ (:file "wm" :depends-on ("recursive-edit")) (:file "minibuffer" :depends-on ("wm")) (:file "simple" :depends-on ("minibuffer")) - (:file "indent" :depends-on ("simple")) + (:file "undo" :depends-on ("simple")) + (:file "indent" :depends-on ("undo")) (:file "syntax" :depends-on ("indent")) (:file "lisp-mode" :depends-on ("wm" "syntax")) (:file "search" :depends-on ("lisp-mode")) diff --git a/lisp-mode.lisp b/lisp-mode.lisp index 7af5664..11bc929 100644 --- a/lisp-mode.lisp +++ b/lisp-mode.lisp @@ -385,12 +385,13 @@ is called as a function to find the defun's beginning." (when (and (< arg 0) (not (eobp))) (forward-char 1)) - (let ((mdata (re-search-backward (if *defun-prompt-regexp* - (concat (if *open-paren-in-column-0-is-defun-start* + (let ((mdata (if *defun-prompt-regexp* + (re-search-backward (concat (if *open-paren-in-column-0-is-defun-start* "^\\(|" "") "(?:" *defun-prompt-regexp* ")\\(") - "\\n\\(") ;; used to be ^\\( - :error 'move :count (or arg 1)))) + :error 'move :count (or arg 1)) + (search-backward (format nil "~%(") + :error 'move :count (or arg 1))))) ;; used to be ^\\( (when mdata (goto-char (1- (match-end mdata 0)))) t)))) diff --git a/main.lisp b/main.lisp index a27ad84..17aee4d 100644 --- a/main.lisp +++ b/main.lisp @@ -14,6 +14,14 @@ (setf *buffer-list* nil) #+movitz (init-commands) (make-default-buffers) + ;; for the scratch buffer + (set-buffer (get-buffer "*scratch*")) + (insert *initial-scratch-message*) + ;; FIXME: is this a hack? + (setf (buffer-modified-p (current-buffer)) nil + (buffer-undo-list (current-buffer)) nil) + (goto-char (point-min)) + (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*")) @@ -21,9 +29,6 @@ #+movitz (make-default-movitz-frame (get-buffer "*scratch*"))) *current-frame* (car *frame-list*) *process-list* nil) - ;; for the scratch buffer - (set-buffer (get-buffer "*scratch*")) - (set-major-mode lisp-interaction-mode) (make-global-keymaps) (catch 'lice-quit #+clisp @@ -129,9 +134,9 @@ (lambda (buffer) (format nil "~C~C" ;; FIXME: add read-only stuff - (if (buffer-modified buffer) + (if (buffer-modified-p buffer) #\* #\-) - (if (buffer-modified buffer) + (if (buffer-modified-p buffer) #\* #\-))) " " (lambda (buffer) diff --git a/recursive-edit.lisp b/recursive-edit.lisp index 9cbc1e6..49ccabb 100644 --- a/recursive-edit.lisp +++ b/recursive-edit.lisp @@ -10,6 +10,8 @@ (let* ((*recursive-edit-depth* (1+ *recursive-edit-depth*)) ;; reset the command keys for the recursive edit (*this-command-keys* nil) + ;; restore the last command + (*last-command* *last-command*) (ret (catch 'exit (with-lice-debugger (loop diff --git a/search.lisp b/search.lisp index 5e5f458..51e19bb 100644 --- a/search.lisp +++ b/search.lisp @@ -21,7 +21,7 @@ Zero means the entire text matched by the whole regexp or whole string." (define-condition search-failed (lice-condition) () (:documentation "raised when a search failed to match")) -(defun search-forward (string &optional bound noerror (count 1)) +(defun search-forward (string &key (bound (zv)) (error t) (count 1)) "Search forward from point for string. Set point to the end of the occurrence found, and return point. An optional second argument bounds the search; it is a buffer position. @@ -35,18 +35,68 @@ Search case-sensitivity is determined by the value of the variable `case-fold-search', which see. See also the functions `match-beginning', `match-end' and `replace-match'." - (declare (ignore bound)) (gap-move-to (current-buffer) (buffer-point-aref (current-buffer))) (let* ((buffer (current-buffer)) pos (n (loop for i from 0 below count - count i - do (setf pos (search string (buffer-data buffer) :start2 (buffer-point-aref buffer))) - while pos))) + do (setf pos (search string (buffer-data buffer) :start2 (buffer-point-aref buffer) :end2 bound)) + while pos + count i))) (if (/= n count) - (when (not noerror) - (signal 'search-failed)) - (goto-char (+ (buffer-aref-to-char buffer pos) (length string)))))) + (cond + ((eq error t) + (signal 'search-failed)) + ((null error) + nil) + (bound + (goto-char bound buffer) + nil) + (t nil)) + (progn + (goto-char (+ (buffer-aref-to-char buffer pos) (length string))) + (make-match-data :obj buffer + :start (buffer-aref-to-char buffer pos) + :end (point buffer) + :reg-starts #() + :reg-ends #()))))) + +(defun search-backward (string &key (bound (begv)) (error t) (count 1)) + "Search backward from point for STRING. +Set point to the beginning of the occurrence found, and return point. +An optional second argument bounds the search; it is a buffer position. +The match found must not extend before that position. +Optional third argument, if t, means if fail just return nil (no error). + If not nil and not t, position at limit of search and return nil. +Optional fourth argument is repeat count--search for successive occurrences. + +Search case-sensitivity is determined by the value of the variable +`case-fold-search', which see. + +See also the functions `match-beginning', `match-end' and `replace-match'." + (gap-move-to (current-buffer) (buffer-point-aref (current-buffer))) + (let* ((buffer (current-buffer)) + pos + (n (loop for i from 0 below count + do (setf pos (search string (buffer-data buffer) :from-end t :end2 (buffer-point-aref buffer) :start2 bound)) + while pos + count i))) + (if (/= n count) + (cond + ((eq error t) + (signal 'search-failed)) + ((null error) + nil) + (bound + (goto-char bound buffer) + nil) + (t nil)) + (progn + (goto-char (buffer-aref-to-char buffer pos)) + (make-match-data :obj buffer + :start (buffer-aref-to-char buffer pos) + :end (+ (buffer-aref-to-char buffer pos) (length string)) + :reg-starts #() + :reg-ends #()))))) (defun looking-at (regexp &optional (buffer (current-buffer))) "Return the match-data if text after point matches regular expression regexp." @@ -100,7 +150,6 @@ and `replace-match'." (buffer-aref-to-char buffer n)) reg-ends))) ((eq error t) - ;; FIXME: we need a search condition (signal 'search-failed)) ((null error) nil) diff --git a/simple.lisp b/simple.lisp index f5d4f8d..4c83b52 100644 --- a/simple.lisp +++ b/simple.lisp @@ -92,42 +92,41 @@ With positive n, a non-empty line at the end counts as one line ((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 - (multiple-value-bind (p lines) - (buffer-scan-newline (current-buffer) - (point) 0 - ;; A little mess to figure out how - ;; many newlines to search for to - ;; give the proper output. - (if (zerop n) - n - (if (and (char-after (point)) - (char= (char-after (point)) #\Newline)) - (- n 2) - (1- n)))) - (when (char= (char-after p) #\Newline) - (incf p)) - (goto-char p) - (when (and (< n 0) - (zerop lines)) - (signal 'beginning-of-buffer)) - (+ n lines))))) + (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) @@ -187,10 +186,10 @@ With arg N, insert N newlines." "Return non-nil if the character after POS is currently invisible." (let ((prop (get-char-property pos 'invisible))) - (if (eq (buffer-local :buffer-invisibility-spec) t) + (if (eq *buffer-invisibility-spec* t) prop - (or (find prop (buffer-local :buffer-invisibility-spec)) - (assoc prop (remove-if-not 'listp (buffer-local :buffer-invisibility-spec))))))) + (or (find prop *buffer-invisibility-spec*) + (assoc prop (remove-if 'listp *buffer-invisibility-spec*)))))) (defcustom track-eol nil "*Non-nil means vertical motion starting at end of line keeps to ends of lines. @@ -205,7 +204,7 @@ Outline mode sets this." :type 'boolean :group 'editing-basics) -(defcustom-buffer-local :goal-column nil +(defcustom-buffer-local *goal-column* nil "*Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil." :type '(choice integer (const :tag "None" nil)) @@ -281,7 +280,7 @@ The value is t if we can move the specified number of lines." 9999 (current-column)))) - (if (and (not (integerp (buffer-local :selective-display))) + (if (and (not (integerp *selective-display*)) (not *line-move-ignore-invisible*)) ;; Use just newline characters. ;; Set ARG to 0 if we move as many lines as requested. @@ -317,7 +316,7 @@ The value is t if we can move the specified number of lines." (signal 'end-of-buffer) (setq done t))) ((and (> arg 1) ;; Use vertical-motion for last move - (not (integerp (buffer-local :selective-display))) + (not (integerp *selective-display*)) (not (line-move-invisible-p (point)))) ;; We avoid vertical-motion when possible ;; because that has to fontify. @@ -339,7 +338,7 @@ The value is t if we can move the specified number of lines." (signal 'beginning-of-buffer nil) (setq done t))) ((and (< arg -1) ;; Use vertical-motion for last move - (not (integerp (buffer-local :selective-display))) + (not (integerp *selective-display*)) (not (line-move-invisible-p (1- (point))))) (forward-line -1)) ((zerop (vertical-motion -1)) @@ -350,7 +349,7 @@ The value is t if we can move the specified number of lines." (setq arg (1+ arg)) (while (and ;; Don't move over previous invis lines ;; if our target is the middle of this line. - (or (zerop (or (buffer-local :goal-column) *temporary-goal-column*)) + (or (zerop (or *goal-column* *temporary-goal-column*)) (< arg 0)) (not (bobp)) (line-move-invisible-p (1- (point)))) (goto-char (previous-char-property-change (point)))))))) @@ -366,7 +365,7 @@ The value is t if we can move the specified number of lines." ;; at least go to beginning of line. (beginning-of-line)) (t - (line-move-finish (or (buffer-local :goal-column) *temporary-goal-column*) + (line-move-finish (or *goal-column* *temporary-goal-column*) opoint forward)))))) (defun line-move-finish (column opoint forward) @@ -531,20 +530,22 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t." (declare (ignore n)) (setf (marker-position (buffer-point (current-buffer))) (buffer-end-of-line))) -(defcommand erase-buffer ((&optional buffer)) +(defcommand erase-buffer ((&optional (buffer (current-buffer)))) "Erase the contents of the current buffer." - (buffer-erase (or buffer (current-buffer)))) + (buffer-erase buffer)) (defcommand execute-extended-command ((prefix) :raw-prefix) "Read a user command from the minibuffer." - (let ((cmd (read-command (case (prefix-numeric-value prefix) - (1 "M-x ") - (4 "C-u M-x ") - (t (format nil "~a M-x " prefix)))))) - (if (lookup-command cmd) + (let* ((name (read-command (case (prefix-numeric-value prefix) + (1 "M-x ") + (4 "C-u M-x ") + (t (format nil "~a M-x " prefix))))) + (cmd (lookup-command name))) + (if cmd (progn - (dispatch-command cmd)) + (dispatch-command name) + (setf *this-command* (command-name cmd))) (message "No Match")))) (defcommand switch-to-buffer ((buffer &optional norecord) @@ -632,6 +633,10 @@ with SIGHUP." (goto-char (marker-position (mark-marker))) (set-marker (mark-marker) p))) +;; FIXME: this variable is here just so code compiles. we still need +;; to implement it. +(defvar transient-mark-mode nil) + (defcommand set-mark-command () (set-marker (mark-marker) (point)) (message "Mark set")) @@ -655,15 +660,19 @@ In Transient Mark mode, this does not activate the mark." ;; (defun kill-ring-save (beg end) ;; "Save the region to the kill ring." -(defcommand scroll-up () +(defcommand scroll-up ((&optional arg) + :raw-prefix) (let ((win (get-current-window))) - (window-scroll-up win (max 1 (- (window-height win) - *next-screen-context-lines*))))) + (window-scroll-up win (max 1 (or (and arg (prefix-numeric-value arg)) + (- (window-height win) + *next-screen-context-lines*)))))) -(defcommand scroll-down () +(defcommand scroll-down ((&optional arg) + :raw-prefix) (let ((win (get-current-window))) - (window-scroll-down win (max 1 (- (window-height win) - *next-screen-context-lines*))))) + (window-scroll-down win (max 1 (or (and arg (prefix-numeric-value arg)) + (- (window-height win) + *next-screen-context-lines*)))))) (defcommand end-of-buffer () "Move point to the end of the buffer; leave mark at previous position. @@ -1077,12 +1086,10 @@ With argument 0, interchanges line point is in with line mark is in." ;;; -(defcustom-buffer-local :fill-prefix nil +(defcustom-buffer-local *fill-prefix* nil "*String for filling to insert at front of new line, or nil for none." :type '(choice (const :tag "None" nil) string) :group 'fill) - - (provide :lice-0.1/simple) diff --git a/subprocesses.lisp b/subprocesses.lisp index ac44dc7..8cb9f98 100644 --- a/subprocesses.lisp +++ b/subprocesses.lisp @@ -169,7 +169,7 @@ buffer is the buffer (or buffer name) to associate with the process. program is the program file name. It is searched for in PATH. Remaining arguments are strings to give program as arguments." (let* ((buf (and buffer (get-buffer-create buffer))) - (mark (and buf (make-marker (point buf) buf)))) + (mark (and buf (copy-marker (point-marker buf))))) (multiple-value-bind (proc input output error) (run-program program program-args) (make-instance 'buffer-subprocess :internal-process proc diff --git a/subr.lisp b/subr.lisp index 30d05c6..a0a0ac0 100644 --- a/subr.lisp +++ b/subr.lisp @@ -140,7 +140,7 @@ provides a file dialog box. See also `read-file-name-completion-ignore-case' and `read-file-name-function'." (declare (ignore predicate initial mustmatch default-filename dir)) - (completing-read prompt #'file-completions :initial-input (princ-to-string (buffer-local :default-directory)))) + (completing-read prompt #'file-completions :initial-input (princ-to-string *default-directory*))) (defun read-string (prompt &optional initial-input history default-value) "Read a string from the minibuffer, prompting with string prompt. diff --git a/textprop.lisp b/textprop.lisp index 23aea98..1eda424 100644 --- a/textprop.lisp +++ b/textprop.lisp @@ -1,5 +1,9 @@ (in-package :lice) +(defvar *inhibit-point-motion-hooks* nil + "If non-nil, don't run `point-left' and `point-entered' text properties. +This also inhibits the use of the `intangible' text property.") + ;; This function is not translated well (defun validate-interval-range (object begin end force) (let (i searchpos) diff --git a/undo.lisp b/undo.lisp new file mode 100644 index 0000000..d8fdb53 --- /dev/null +++ b/undo.lisp @@ -0,0 +1,622 @@ +;;; 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))) + diff --git a/window.lisp b/window.lisp index 37c24f0..71b50c7 100644 --- a/window.lisp +++ b/window.lisp @@ -86,9 +86,10 @@ scrolling up (towards the beginning of the buffer).")) ;; (window-2d-display window) d))) (defun make-window (&key x y cols rows buffer frame - (top (make-marker 0 buffer)) - (bpoint (make-marker)) - (type 'window)) + (top (make-marker)) + (bpoint (make-marker)) + (bottom (make-marker)) + (type 'window)) "Return a new window. This is handy for setting up all the pesky display structures. @@ -104,11 +105,13 @@ TYPE isn't used yet. it's just there for hype." :point-line 0 :buffer buffer :top top - :bottom (make-marker 0 buffer) + :bottom bottom :bpoint bpoint :point-col 0 :point-line 0))) (set-marker bpoint (point buffer) buffer) + (set-marker top (begv buffer) buffer) + (set-marker bottom (begv buffer) buffer) w)) (defun make-test-window (buffer) @@ -140,6 +143,10 @@ for horizontal splits, is not included in the width." 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)) + (defun set-window-buffer (window buffer &optional keep-margins) "Make WINDOW display BUFFER as its contents. BUFFER can be a buffer or buffer name. @@ -410,7 +417,7 @@ starting line." worth of lines and return T if POINT was in the line cache. otherwise don't change anything and return nil." (let* ((lines (generate-n-lines-forward (window-buffer window) (window-width window) - (marker-position (window-top window)) + (marker-position (window-top window)) (window-height window)))) (add-end-of-buffer (window-buffer window) lines) (when (or always-return-lines @@ -700,8 +707,8 @@ LINES many lines, moving the window point to be visible." (defun delete-window (&optional (window (selected-window))) (check-type window window) - (when (or (typep window minibuffer-window) - (typep (frame-window-tree frame) 'window)) + (when (or (typep window 'minibuffer-window) + (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) diff --git a/wm.lisp b/wm.lisp index 794c664..558162d 100644 --- a/wm.lisp +++ b/wm.lisp @@ -41,29 +41,29 @@ (let ((frame frame) cw) (labels ((restore-window (bk) - (let ((w (make-window :frame frame - :x (window-bk-x bk) - :y (window-bk-y bk) - :cols (window-bk-w bk) - :rows (window-bk-h bk) - :buffer (window-bk-buffer bk) - :top (window-bk-top bk) - :bpoint (window-bk-bpoint bk)))) - (unless (get-buffer (window-bk-buffer bk)) - ;; default to scratch for deleted buffers - (let ((scratch (get-buffer-create "*scratch*"))) - (setf (window-buffer w) scratch - (window-top w) (make-marker 0 scratch) - (window-bpoint w) (make-marker 0 scratch)))) - (setf (window-seperator w) (window-bk-seperator bk)) - (when (eq bk (frame-bk-current-window configuration)) - (setf cw w)) - w)) + (let ((w (make-window :frame frame + :x (window-bk-x bk) + :y (window-bk-y bk) + :cols (window-bk-w bk) + :rows (window-bk-h bk) + :buffer (window-bk-buffer bk) + :top (window-bk-top bk) + :bpoint (window-bk-bpoint bk)))) + (unless (get-buffer (window-bk-buffer bk)) + ;; default to scratch for deleted buffers + (let ((scratch (get-buffer-create "*scratch*"))) + (setf (window-buffer w) scratch + (window-top w) (set-marker (make-marker) 0 scratch) + (window-bpoint w) (set-marker (make-marker) 0 scratch)))) + (setf (window-seperator w) (window-bk-seperator bk)) + (when (eq bk (frame-bk-current-window configuration)) + (setf cw w)) + w)) (restore-tree (tree) - (cond ((typep tree 'window-bk) - (restore-window tree)) - (t (list (restore-tree (first tree)) - (restore-tree (second tree))))))) + (cond ((typep tree 'window-bk) + (restore-window tree)) + (t (list (restore-tree (first tree)) + (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) -- 2.11.4.GIT