Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv23493

Modified Files: ttcn3-syntax.lisp text-syntax.lisp syntax.lisp slidemacs.lisp search-commands.lisp prolog-syntax.lisp packages.lisp misc-commands.lisp lisp-syntax.lisp lisp-syntax-commands.lisp html-syntax.lisp gui.lisp fundamental-syntax.lisp file-commands.lisp climacs.asd cl-syntax.lisp buffer.lisp base.lisp Added Files: motion.lisp motion-commands.lisp editing.lisp editing-commands.lisp Log Message: Major motion and editing functions and commands refactoring (see the thread "paredit.lisp, regularization of motion commands, and more" on climacs-devel for full details).

Breakage not found during testing, but still expected.

--- /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/05/06 19:51:04 1.5 +++ /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/06/12 19:10:58 1.6 @@ -372,7 +372,7 @@ (incf valid-parse))))

(defmethod inter-lexeme-object-p ((lexer ttcn3-lexer) object) - (whitespacep object)) + (whitespacep (syntax (buffer lexer)) object))

(defmethod update-syntax (buffer (syntax ttcn3-syntax)) (with-slots (lexer valid-parse) syntax @@ -392,7 +392,8 @@ (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (and (< start end) - (whitespacep (buffer-object buffer start))) + (whitespacep (syntax buffer) + (buffer-object buffer start))) do (ecase (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) --- /project/climacs/cvsroot/climacs/text-syntax.lisp 2005/08/06 20:51:19 1.9 +++ /project/climacs/cvsroot/climacs/text-syntax.lisp 2006/06/12 19:10:58 1.10 @@ -148,16 +148,17 @@ (incf pos1)) (t nil))))))))

-(defmethod backward-paragraph (mark (syntax text-syntax)) +(defmethod backward-one-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax (let ((pos1 (index-of-mark-after-offset paragraphs (offset mark)))) (when (> pos1 0) (setf (offset mark) (if (typep (element* paragraphs (1- pos1)) 'right-sticky-mark) (offset (element* paragraphs (- pos1 2))) - (offset (element* paragraphs (1- pos1))))))))) + (offset (element* paragraphs (1- pos1))))) + t))))

-(defmethod forward-paragraph (mark (syntax text-syntax)) +(defmethod forward-one-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax (let ((pos1 (index-of-mark-after-offset paragraphs @@ -168,16 +169,18 @@ (setf (offset mark) (if (typep (element* paragraphs pos1) 'left-sticky-mark) (offset (element* paragraphs (1+ pos1))) - (offset (element* paragraphs pos1)))))))) + (offset (element* paragraphs pos1)))) + t))))

- (defmethod backward-sentence (mark (syntax text-syntax)) + (defmethod backward-one-sentence (mark (syntax text-syntax)) (with-slots (sentence-beginnings) syntax (let ((pos1 (index-of-mark-after-offset sentence-beginnings (offset mark)))) (when (> pos1 0) - (setf (offset mark) - (offset (element* sentence-beginnings (1- pos1)))))))) + (setf (offset mark) + (offset (element* sentence-beginnings (1- pos1)))) + t))))

- (defmethod forward-sentence (mark (syntax text-syntax)) + (defmethod forward-one-sentence (mark (syntax text-syntax)) (with-slots (sentence-endings) syntax (let ((pos1 (index-of-mark-after-offset sentence-endings @@ -186,13 +189,14 @@ (1+ (offset mark))))) (when (< pos1 (nb-elements sentence-endings)) (setf (offset mark) - (offset (element* sentence-endings pos1))))))) + (offset (element* sentence-endings pos1))) + t))))

(defmethod syntax-line-indentation (mark tab-width (syntax text-syntax)) (loop with indentation = 0 with mark2 = (clone-mark mark) until (beginning-of-buffer-p mark2) - do (previous-line mark2) + do (climacs-motion:backward-line mark2 syntax) (setf indentation (line-indentation mark2 tab-width)) while (empty-line-p mark2) finally (return indentation))) --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/06/04 16:21:06 1.65 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/06/12 19:10:58 1.66 @@ -50,49 +50,8 @@ (:documentation "Return the correct indentation for the line containing the mark, according to the specified syntax."))

-(defgeneric forward-expression (mark syntax)) - -(defgeneric backward-expression (mark syntax)) - (defgeneric eval-defun (mark syntax))

-(defgeneric beginning-of-definition (mark syntax)) - -(defgeneric end-of-definition (mark syntax)) - -(defgeneric backward-paragraph (mark syntax)) - -(defgeneric forward-paragraph (mark syntax)) - -(defgeneric backward-sentence (mark syntax)) - -(defgeneric forward-sentence (mark syntax)) - -(defgeneric forward-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric backward-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric down-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric backward-down-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric backward-up-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric up-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting @@ -298,33 +257,9 @@ (declare (ignore mark tab-width)) 0)

-(defmethod forward-expression (mark syntax) - (error 'no-such-operation)) - -(defmethod backward-expression (mark syntax) - (error 'no-such-operation)) - (defmethod eval-defun (mark syntax) (error 'no-such-operation))

-(defmethod beginning-of-defintion (mark syntax) - (error 'no-such-operation)) - -(defmethod end-of-definition (mark syntax) - (error 'no-such-operation)) - -(defmethod backward-paragraph (mark syntax) - (error 'no-such-operation)) - -(defmethod forward-paragraph (mark syntax) - (error 'no-such-operation)) - -(defmethod backward-sentence (mark syntax) - (error 'no-such-operation)) - -(defmethod forward-sentence (mark syntax) - (error 'no-such-operation)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Incremental Earley parser @@ -789,3 +724,34 @@

(defgeneric redisplay-pane-with-syntax (pane syntax current-p))

+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Querying + +(defgeneric word-constituentp (syntax obj) + (:documentation "Return T if `obj' is a word constituent + character in `syntax'.") + (:method (syntax obj) + nil) + (:method (syntax (obj character)) + (alphanumericp obj))) + +(defgeneric whitespacep (syntax obj) + (:documentation "Return T if `obj' is a whitespace character in + `syntax'.") + (:method (syntax obj) + nil) + (:method (syntax (obj character)) + (member obj '(#\Space #\Tab #\Newline #\Page #\Return)))) + +(defgeneric page-delimiter (syntax) + (:documentation "Return the object sequence used as a page + deliminter in `syntax'.") + (:method (syntax) + '(#\Newline #\Page))) + +(defgeneric paragraph-delimiter (syntax) + (:documentation "Return the object used as a paragraph + deliminter in `syntax'.") + (:method (syntax) + '(#\Newline #\Newline))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/05/06 19:51:04 1.9 +++ /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/06/12 19:10:58 1.10 @@ -363,7 +363,7 @@ nil)

(defmethod inter-lexeme-object-p ((lexer slidemacs-lexer) object) - (whitespacep object)) + (whitespacep (syntax (buffer lexer)) object))

(defmethod update-syntax (buffer (syntax slidemacs-editor-syntax)) (with-slots (parser lexer valid-parse) syntax @@ -389,7 +389,8 @@ (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (and (< start end) - (whitespacep (buffer-object buffer start))) + (whitespacep (syntax buffer) + (buffer-object buffer start))) do (ecase (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/26 22:41:54 1.6 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/06/12 19:10:58 1.7 @@ -538,11 +538,13 @@ with start = 0 while (< index length) do (loop until (>= index length) - while (whitespacep (char contents index)) + while (whitespacep (syntax buffer) + (char contents index)) do (incf index)) (setf start index) (loop until (>= index length) - until (whitespacep (char contents index)) + until (whitespacep (syntax buffer) + (char contents index)) do (incf index)) until (= start index) collecting (string-trim '(#\Space #\Tab #\Newline) --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/05/06 19:51:04 1.27 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/06/12 19:10:58 1.28 @@ -302,7 +302,8 @@ (t (cond ((and (string= string ".") - (or (whitespacep (object-after scan)) + (or (whitespacep (syntax (buffer lexer)) + (object-after scan)) (eql (object-after scan) #%))) (return (make-instance 'end-lexeme))) (t (return (make-instance 'graphic-lexeme)))))) @@ -372,7 +373,8 @@ (when (or (end-of-buffer-p scan) (let ((object (object-after scan))) (or (eql object #%) - (whitespacep object)))) + (whitespacep (syntax (buffer lexer)) + object)))) (bo) (return (make-instance 'integer-lexeme))) (loop until (end-of-buffer-p scan) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/06/06 16:50:36 1.99 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/06/12 19:10:58 1.100 @@ -32,7 +32,10 @@ #:invalid-motion #:motion-before-beginning #:motion-after-end #:size #:number-of-lines #:offset #:mark< #:mark<= #:mark= #:mark> #:mark>= - #:forward-object #:backward-object + #:forward-object + #:backward-object + #:forward-line-start #:backward-line-start + #:forward-line-end #:backward-line-end #:beginning-of-buffer #:end-of-buffer #:beginning-of-buffer-p #:end-of-buffer-p #:beginning-of-line #:end-of-line @@ -47,44 +50,41 @@ #:buffer-object #:buffer-sequence #:object-before #:object-after #:region-to-sequence #:low-mark #:high-mark #:modified-p #:clear-modify - #:binseq-buffer #:obinseq-buffer #:binseq2-buffer #:persistent-left-sticky-mark #:persistent-right-sticky-mark #:persistent-left-sticky-line-mark #:persistent-right-sticky-line-mark #:p-line-mark-mixin #:buffer-line-offset - #:delegating-buffer #:implementation))

+(defpackage :climacs-kill-ring + (:use :clim-lisp :flexichain) + (:export #:kill-ring + #:kill-ring-length #:kill-ring-max-size + #:append-next-p + #:reset-yank-position #:rotate-yank-position #:kill-ring-yank + #:kill-ring-standard-push #:kill-ring-concatenating-push + #:kill-ring-reverse-concatenating-push)) + (defpackage :climacs-base - (:use :clim-lisp :climacs-buffer) + (:use :clim-lisp :climacs-buffer :climacs-kill-ring) (:export #:do-buffer-region #:do-buffer-region-lines #:previous-line #:next-line - #:open-line #:kill-line #:empty-line-p #:line-indentation #:buffer-display-column #:number-of-lines-in-region - #:constituentp #:whitespacep + #:constituentp #:forward-word #:backward-word - #:delete-word #:backward-delete-word #:buffer-region-case - #:upcase-buffer-region #:upcase-region - #:downcase-buffer-region #:downcase-region - #:capitalize-buffer-region #:capitalize-region - #:upcase-word #:downcase-word #:capitalize-word - #:tabify-region #:untabify-region - #:indent-line - #:indent-region - #:delete-indentation - #:fill-line #:fill-region #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-looking-at #:looking-at #:buffer-search-forward #:buffer-search-backward #:buffer-re-search-forward #:buffer-re-search-backward #:search-forward #:search-backward - #:re-search-forward #:re-search-backward)) + #:re-search-forward #:re-search-backward + #:*kill-ring*))

(defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) @@ -125,15 +125,11 @@ #:backward-down-list #:backward-up-list #:syntax-line-comment-string #:line-comment-region #:comment-region - #:line-uncomment-region #:uncomment-region)) - -(defpackage :climacs-kill-ring - (:use :clim-lisp :flexichain) - (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size - #:append-next-p - #:reset-yank-position #:rotate-yank-position #:kill-ring-yank - #:kill-ring-standard-push #:kill-ring-concatenating-push - #:kill-ring-reverse-concatenating-push)) + #:line-uncomment-region #:uncomment-region + #:word-constituentp + #:whitespacep + #:page-delimiter + #:paragraph-delimiter))

(defpackage :undo (:use :common-lisp) @@ -168,10 +164,129 @@ #:url #:climacs-textual-view #:+climacs-textual-view+))

+(defpackage :climacs-motion + (:use :clim-lisp :clim :climacs-base :climacs-buffer :climacs-syntax) + (:export #:forward-to-word-boundary #:backward-to-word-boundary + #:define-motion-fns + #:beep-limit-action #:revert-limit-action #:error-limit-action + #:motion-limit-error + #:make-diligent-motor + + ;; Lines + #:forward-one-line + #:backward-one-line + #:forward-line + #:backward-line + + ;; Words + #:forward-one-word + #:backward-one-word + #:forward-word + #:backward-word + + ;; Pages + #:forward-one-page + #:backward-one-page + #:forward-page + #:backward-page + + ;; Expressions + #:forward-one-expression + #:backward-one-expression + #:forward-expression + #:backward-expression + + ;; Definitions + #:forward-one-definition + #:backward-one-definition + #:forward-definition + #:backward-definition + + ;; Up + #:forward-one-up + #:backward-one-up + #:forward-up + #:backward-up + + ;; Down + #:forward-one-down + #:backward-one-down + #:forward-down + #:backward-down + + ;; Paragraphs + #:forward-one-paragraph + #:backward-one-paragraph + #:forward-paragraph + #:backward-paragraph + + ;; Sentences + #:forward-one-sentence + #:backward-one-sentence + #:forward-sentence + #:backward-sentence)) + +(defpackage :climacs-editing + (:use :clim-lisp :clim :climacs-base :climacs-buffer + :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring) + (:export #:transpose-objects + #:open-line + + ;; Lines + #:forward-delete-line #:backward-delete-line + #:forward-kill-line #:backward-kill-line + #:transpose-lines + #:forward-delete-line-start #:backward-delete-line-start + #:forward-kill-line-start #:backward-kill-line-start + #:transpose-line-starts + + ;; Words + #:forward-delete-word #:backward-delete-word + #:forward-kill-word #:backward-kill-word + #:transpose-words + + ;; Pages + #:forward-delete-page #:backward-delete-page + #:forward-kill-page #:backward-kill-page + #:transpose-page + + ;; Expressions + #:forward-delete-expression #:backward-delete-expression + #:forward-kill-expression #:backward-kill-expression + #:transpose-expressions + + ;; Definitions + #:forward-delete-definition #:backward-delete-definition + #:forward-kill-definition #:backward-kill-definition + #:transpose-definitions + + ;; Paragraphs + #:forward-delete-paragraph #:backward-delete-paragraph + #:forward-kill-paragraph #:backward-kill-paragraph + #:transpose-paragraphs + + ;; Sentences + #:forward-delete-sentence #:backward-delete-sentence + #:forward-kill-sentence #:backward-kill-sentence + #:transpose-sentences + + #:downcase-buffer-region #:downcase-region + #:upcase-buffer-region #:upcase-region + #:downcase-word #:upcase-word + #:capitalize-buffer-region #:capitalize-region + #:capitalize-word + #:tabify-region #:untabify-region + #:indent-line + #:indent-region + #:delete-indentation + #:fill-line + #:fill-region)) + (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-abbrev :climacs-syntax - :climacs-kill-ring :climacs-pane :clim-extensions :undo :esa) + :climacs-abbrev :climacs-syntax :climacs-motion + :climacs-kill-ring :climacs-pane :clim-extensions + :undo :esa :climacs-editing :climacs-motion) ;;(:import-from :lisp-string) (:export :climacs ; Main entry point. ;; GUI functions follow. @@ -183,7 +298,35 @@ :point :syntax :mark - :insert-character)) + :insert-character + :base-table + :buffer-table + :case-table + :comment-table + :deletion-table + :development-table + :editing-table + :fill-table + :indent-table + :info-table + :marking-table + :movement-table + :pane-table + :search-table + :self-insert-table + :window-table)) + +(defpackage :climacs-motion-commands + (:use :clim-lisp :clim :climacs-base :climacs-buffer + :climacs-syntax :climacs-motion :climacs-gui :esa) + (:export #:define-motion-commands)) + +(defpackage :climacs-editing-commands + (:use :clim-lisp :clim :climacs-base :climacs-buffer + :climacs-syntax :climacs-motion :climacs-gui + :esa :climacs-editing :climacs-kill-ring) + (:export #:define-deletion-commands + #:define-editing-commands))

(defpackage :climacs-fundamental-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base @@ -206,7 +349,5 @@

(defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane :climacs-gui) - (:export :lisp-string)) - - + :climacs-syntax :flexichain :climacs-pane :climacs-gui :climacs-motion :climacs-editing) + (:export :lisp-string)) \ No newline at end of file --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/06/03 17:58:04 1.14 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/06/12 19:10:58 1.15 @@ -85,14 +85,15 @@ (lambda (mark) (syntax-line-indentation mark tab-width syntax)) fill-column - tab-width)))))) + tab-width + (syntax buffer)))))))

(defun insert-character (char) (let* ((window (current-window)) (point (point window))) (unless (constituentp char) (possibly-expand-abbrev point)) - (when (whitespacep char) + (when (whitespacep (syntax (buffer window)) char) (possibly-fill-line)) (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point))) (progn @@ -103,73 +104,6 @@ (define-command com-self-insert ((count 'integer)) (loop repeat count do (insert-character *current-gesture*)))

-(define-command (com-beginning-of-line :name t :command-table movement-table) () - "Move point to the beginning of the current line." - (beginning-of-line (point (current-window)))) - -(set-key 'com-beginning-of-line - 'movement-table - '((:home))) - -(set-key 'com-beginning-of-line - 'movement-table - '((#\a :control))) - -(define-command (com-end-of-line :name t :command-table movement-table) () - "Move point to the end of the current line." - (end-of-line (point (current-window)))) - -(set-key 'com-end-of-line - 'movement-table - '((#\e :control))) - -(set-key 'com-end-of-line - 'movement-table - '((:end))) - -(define-command (com-delete-object :name t :command-table deletion-table) - ((count 'integer :prompt "Number of Objects") - (killp 'boolean :prompt "Kill?")) - "Delete the object after point. -With a numeric argument, kill that many objects -after (or before, if negative) point." - (let* ((point (point (current-window))) - (mark (clone-mark point))) - (forward-object mark count) - (when killp - (kill-ring-standard-push *kill-ring* - (region-to-sequence point mark))) - (delete-region point mark))) - -(set-key `(com-delete-object ,*numeric-argument-marker* - ,*numeric-argument-p*) - 'deletion-table - '(#\Rubout)) - -(set-key `(com-delete-object ,*numeric-argument-marker* - ,*numeric-argument-p*) - 'deletion-table - '((#\d :control))) - -(define-command (com-backward-delete-object :name t :command-table deletion-table) - ((count 'integer :prompt "Number of Objects") - (killp 'boolean :prompt "Kill?")) - "Delete the object before point. -With a numeric argument, kills that many objects -before (or after, if negative) point." - (let* ((point (point (current-window))) - (mark (clone-mark point))) - (backward-object mark count) - (when killp - (kill-ring-standard-push *kill-ring* - (region-to-sequence mark point))) - (delete-region mark point))) - -(set-key `(com-backward-delete-object ,*numeric-argument-marker* - ,*numeric-argument-p*) - 'deletion-table - '(#\Backspace)) - (define-command (com-zap-to-object :name t :command-table deletion-table) () "Prompt for an object and kill to the next occurence of that object after point. Characters can be entered in #\ format." @@ -206,174 +140,6 @@ 'deletion-table '((#\z :meta)))

-(defun transpose-objects (mark) - (unless (beginning-of-buffer-p mark) - (when (end-of-line-p mark) - (backward-object mark)) - (unless (beginning-of-buffer-p mark) - (let ((object (object-after mark))) - (delete-range mark) - (backward-object mark) - (insert-object mark object) - (forward-object mark))))) - -(define-command (com-transpose-objects :name t :command-table editing-table) () - "Transpose the objects before and after point, advancing point. -At the end of a line transpose the previous two objects without -advancing point. At the beginning of the buffer do nothing. -At the beginning of any line other than the first effectively -move the first object of that line to the end of the previous line." - (transpose-objects (point (current-window)))) - -(set-key 'com-transpose-objects - 'editing-table - '((#\t :control))) - -(define-command (com-backward-object :name t :command-table movement-table) - ((count 'integer :prompt "Number of Objects")) - "Move point backward one object. -With a numeric argument, move point backward (or forward, if negative) -that number of objects." - (backward-object (point (current-window)) count)) - -(set-key `(com-backward-object ,*numeric-argument-marker*) - 'movement-table - '((#\b :control))) - -(set-key `(com-backward-object ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :left #-mcclim :left-arrow))) - -(define-command (com-forward-object :name t :command-table movement-table) - ((count 'integer :prompt "Number of Objects")) - "Move point forward one object. -With a numeric argument, move point forward (or backward, if negative) -that number of objects." - (forward-object (point (current-window)) count)) - -(set-key `(com-forward-object ,*numeric-argument-marker*) - 'movement-table - '((#\f :control))) - -(set-key `(com-forward-object ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :right #-mcclim :right-arrow))) - -(defun transpose-words (mark) - (let (bw1 bw2 ew1 ew2) - (backward-word mark) - (setf bw1 (offset mark)) - (forward-word mark) - (setf ew1 (offset mark)) - (forward-word mark) - (when (= (offset mark) ew1) - (display-message "Don't have two things to transpose")) - (setf ew2 (offset mark)) - (backward-word mark) - (setf bw2 (offset mark)) - (let ((w2 (buffer-sequence (buffer mark) bw2 ew2)) - (w1 (buffer-sequence (buffer mark) bw1 ew1))) - (delete-word mark) - (insert-sequence mark w1) - (backward-word mark) - (backward-word mark) - (delete-word mark) - (insert-sequence mark w2) - (forward-word mark)))) - -(define-command (com-transpose-words :name t :command-table editing-table) () - "Transpose the words around point, leaving point at the end of them. -With point in the whitespace between words, transpose the words before -and after point. With point inside a word, transpose that word with -the next one. With point before the first word of the buffer, transpose -the first two words of the buffer. - -FIXME: with point after the penultimate word of the buffer, -or if there are <2 words in the buffer, Strange Things (TM) -happen (including breaking Climacs)." - (transpose-words (point (current-window)))) - -(set-key 'com-transpose-words - 'editing-table - '((#\t :meta))) - -(defun transpose-lines (mark) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (previous-line mark)) - (let* ((bol (offset mark)) - (eol (progn (end-of-line mark) - (offset mark))) - (line (buffer-sequence (buffer mark) bol eol))) - (delete-region bol mark) - ;; Remove newline at end of line as well. - (unless (end-of-buffer-p mark) - (delete-range mark)) - ;; If the current line is at the end of the buffer, we want to - ;; be able to insert past it, so we need to get an extra line - ;; at the end. - (end-of-line mark) - (when (end-of-buffer-p mark) - (insert-object mark #\Newline)) - (next-line mark 0) - (insert-sequence mark line) - (insert-object mark #\Newline))) - -(define-command (com-transpose-lines :name t :command-table editing-table) () - "Transpose current line and previous line, leaving point at the end of them. -If point is in the first line, transpose the first two lines. -If point is in the last line of the buffer and there is no -final #\Newline, add one." - (transpose-lines (point (current-window)))) - -(set-key 'com-transpose-lines - 'editing-table - '((#\x :control) (#\t :control))) - -(define-command (com-previous-line :name t :command-table movement-table) - ((numarg 'integer :prompt "How many lines?")) - "Move point to the previous line. -With a numeric argument, move point up (down, if negative) that many lines. -Successive line movement commands seek to respect the 'goal column'." - (let* ((window (current-window)) - (point (point window))) - (unless (or (eq (previous-command window) 'com-previous-line) - (eq (previous-command window) 'com-next-line)) - (setf (slot-value window 'goal-column) (column-number point))) - (if (plusp numarg) - (previous-line point (slot-value window 'goal-column) numarg) - (next-line point (slot-value window 'goal-column) (- numarg))))) - -(set-key `(com-previous-line ,*numeric-argument-marker*) - 'movement-table - '((#\p :control))) - -(set-key `(com-previous-line ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :up #-mcclim :up-arrow))) - -(define-command (com-next-line :name t :command-table movement-table) - ((numarg 'integer :prompt "How many lines?")) - "Move point to the next line. -With a numeric argument, move point down (up, if negative) that many lines. -Successive line movement commands seek to respect the 'goal column'." - (let* ((window (current-window)) - (point (point window))) - (unless (or (eq (previous-command window) 'com-previous-line) - (eq (previous-command window) 'com-next-line)) - (setf (slot-value window 'goal-column) (column-number point))) - (if (plusp numarg) - (next-line point (slot-value window 'goal-column) numarg) - (previous-line point (slot-value window 'goal-column) (- numarg))))) - -(set-key `(com-next-line ,*numeric-argument-marker*) - 'movement-table - '((#\n :control))) - -(set-key `(com-next-line ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :down #-mcclim :down-arrow))) - (define-command (com-open-line :name t :command-table editing-table) ((numarg 'integer :prompt "How many lines?")) "Insert a #\Newline and leave point before it. @@ -402,7 +168,7 @@ do (forward-object mark))) (t (cond ((end-of-buffer-p mark) nil) - ((end-of-line-p mark)(forward-object mark)) + ((end-of-line-p mark) (forward-object mark)) (t (end-of-line mark))))) (unless (mark= mark start) (if concatenate-p @@ -431,122 +197,64 @@ 'deletion-table '((#\k :control)))

-(define-command (com-forward-word :name t :command-table movement-table) - ((count 'integer :prompt "Number of words")) - "Move point to the next word end. -With a numeric argument, move point forward (backward, if negative) -that many words." - (if (plusp count) - (forward-word (point (current-window)) count) - (backward-word (point (current-window)) (- count)))) - -(set-key `(com-forward-word ,*numeric-argument-marker*) - 'movement-table - '((#\f :meta))) - -(set-key `(com-forward-word ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :right #-mcclim :right-arrow :control))) - -(define-command (com-backward-word :name t :command-table movement-table) - ((count 'integer :prompt "Number of words")) - "Move point to the previous word beginning. -With a numeric argument, move point backward (forward, if negative) -that many words." - (backward-word (point (current-window)) count)) - -(set-key `(com-backward-word ,*numeric-argument-marker*) - 'movement-table - '((#\b :meta))) - -(set-key `(com-backward-word ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :left #-mcclim :left-arrow :control))) - -(define-command (com-delete-word :name t :command-table deletion-table) - ((count 'integer :prompt "Number of words")) - "Delete from point until the next word end. -With a positive numeric argument, delete that many words forward." - (delete-word (point (current-window)) count)) - -(defun kill-word (mark &optional (count 1) (concatenate-p nil)) - (let ((start (offset mark))) - (if (plusp count) - (loop repeat count - until (end-of-buffer-p mark) - do (forward-word mark)) - (loop repeat (- count) - until (beginning-of-buffer-p mark) - do (backward-word mark))) - (unless (mark= mark start) - (if concatenate-p - (if (plusp count) - (kill-ring-concatenating-push *kill-ring* - (region-to-sequence start mark)) - (kill-ring-reverse-concatenating-push *kill-ring* - (region-to-sequence start mark))) - (kill-ring-standard-push *kill-ring* - (region-to-sequence start mark))) - (delete-region start mark)))) - -(define-command (com-kill-word :name t :command-table deletion-table) - ((count 'integer :prompt "Number of words")) - "Kill from point until the next word end. -With a numeric argument, kill forward (backward, if negative) -that many words. - -Successive kills append to the kill ring." - (let* ((pane (current-window)) - (point (point pane)) - (concatenate-p (eq (previous-command pane) 'com-kill-word))) - (kill-word point count concatenate-p))) - -(set-key `(com-kill-word ,*numeric-argument-marker*) - 'deletion-table - '((#\d :meta))) - -(define-command (com-backward-kill-word :name t :command-table deletion-table) - ((count 'integer :prompt "Number of words")) - "Kill from point until the previous word beginning. -With a numeric argument, kill backward (forward, if negative) -that many words. - -Successive kills append to the kill ring." - (let* ((pane (current-window)) - (point (point pane)) - (concatenate-p (eq (previous-command pane) 'com-backward-kill-word))) - (kill-word point (- count) concatenate-p))) - -(set-key `(com-backward-kill-word ,*numeric-argument-marker*) - 'deletion-table - '((#\Backspace :meta))) - -(define-command (com-mark-word :name t :command-table marking-table) - ((count 'integer :prompt "Number of words")) - "Place mark at the next word end. +(defmacro define-mark-unit-command (unit command-table &key + move-point + noun + plural) + "Define a COM-MARK-<UNIT> for `unit' command and put it in + `command-table'." + (labels ((symbol (&rest strings) + (intern (apply #'concat strings))) + (concat (&rest strings) + (apply #'concatenate 'STRING (mapcar #'string strings)))) + (let ((forward (symbol "FORWARD-" unit)) + (backward (symbol "BACKWARD-" unit)) + (noun (or noun (string-downcase unit))) + (plural (or plural (concat (string-downcase unit) "s")))) + `(define-command (,(symbol "COM-MARK-" unit) + :name t + :command-table ,command-table) + ((count 'integer :prompt ,(concat "Number of " plural))) + ,(if (not (null move-point)) + (concat "Place point and mark around the current " noun ". +Put point at the beginning of the current " noun ", and mark at the end. +With a positive numeric argument, put mark that many " plural " forward. +With a negative numeric argument, put point at the end of the current +" noun " and mark that many " plural " backward. +Successive invocations extend the selection.")

[700 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/12 10:48:29 1.86 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/12 19:10:58 1.87 @@ -246,7 +246,7 @@ (macrolet ((fo () `(forward-object scan))) (loop when (end-of-buffer-p scan) do (return nil) - until (not (whitespacep (object-after scan))) + until (not (whitespacep syntax (object-after scan))) do (fo) finally (return t))))

@@ -434,7 +434,7 @@ (defmethod skip-inter ((syntax lisp-syntax) (state lexer-line-comment-state) scan) (macrolet ((fo () `(forward-object scan))) (loop until (or (end-of-line-p scan) - (not (whitespacep (object-after scan)))) + (not (whitespacep syntax (object-after scan)))) do (fo) finally (return t))))

@@ -520,7 +520,7 @@ (fo) (go start)) (if (evenp bars-seen) - (unless (whitespacep (object-after scan)) + (unless (whitespacep syntax (object-after scan)) (fo) (go start)) (when (constituentp (object-after scan)) @@ -1823,47 +1823,57 @@ (when (not (null list-child)) (funcall fn list-child)))))

-(defmethod backward-expression (mark (syntax lisp-syntax)) +(defmethod backward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) (if potential-form (setf (offset mark) (start-offset potential-form)) (error 'no-expression))))

-(defmethod forward-expression (mark (syntax lisp-syntax)) +(defmethod forward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-after syntax (offset mark)) (form-around syntax (offset mark))))) (if potential-form (setf (offset mark) (end-offset potential-form)) (error 'no-expression))))

-(defmethod forward-list (mark (syntax lisp-syntax)) +(defgeneric forward-one-list (mark syntax) + (:documentation + "Move `mark' forward by one list. +Return T if successful, or NIL if the buffer limit was reached.")) + +(defmethod forward-one-list (mark (syntax lisp-syntax)) (loop for start = (offset mark) - then (end-offset potential-form) - for potential-form = (or (form-after syntax start) - (form-around syntax start)) - until (or (null potential-form) - (and (= start - (end-offset potential-form)) - (null (form-after syntax start)))) - when (typep potential-form 'list-form) - do (setf (offset mark) (end-offset potential-form)) - (return) - finally (error 'no-expression))) + then (end-offset potential-form) + for potential-form = (or (form-after syntax start) + (form-around syntax start)) + until (or (null potential-form) + (and (= start + (end-offset potential-form)) + (null (form-after syntax start)))) + when (typep potential-form 'list-form) + do (setf (offset mark) (end-offset potential-form)) + (return t))) + +(defgeneric backward-one-list (mark syntax) + (:documentation + "Move `mark' backward by one list. Return T if successful, or +NIL if the buffer limit was reached."))

-(defmethod backward-list (mark (syntax lisp-syntax)) +(defmethod backward-one-list (mark (syntax lisp-syntax)) (loop for start = (offset mark) - then (start-offset potential-form) - for potential-form = (or (form-before syntax start) - (form-around syntax start)) - until (or (null potential-form) - (and (= start - (start-offset potential-form)) - (null (form-before syntax start)))) - when (typep potential-form 'list-form) - do (setf (offset mark) (start-offset potential-form)) - (return) - finally (error 'no-expression))) + then (start-offset potential-form) + for potential-form = (or (form-before syntax start) + (form-around syntax start)) + until (or (null potential-form) + (and (= start + (start-offset potential-form)) + (null (form-before syntax start)))) + when (typep potential-form 'list-form) + do (setf (offset mark) (start-offset potential-form)) + (return t))) + +(climacs-motion:define-motion-fns list)

(defun down-list-by-fn (mark syntax fn) (let* ((offset (offset mark)) @@ -1876,31 +1886,30 @@ fn offset))))) (when new-offset - (setf (offset mark) (1+ new-offset)))))) + (progn (setf (offset mark) (1+ new-offset)) t)))))

-(defmethod down-list (mark (syntax lisp-syntax)) +(defmethod forward-one-down (mark (syntax lisp-syntax)) (down-list-by-fn mark syntax #'start-offset))

-(defmethod backward-down-list (mark (syntax lisp-syntax)) +(defmethod backward-one-down (mark (syntax lisp-syntax)) (down-list-by-fn mark syntax #'end-offset) - (backward-object mark)) + (backward-object mark syntax))

(defun up-list-by-fn (mark syntax fn) (let ((form (or (form-before syntax (offset mark)) (form-after syntax (offset mark)) (form-around syntax (offset mark))))) - (if form + (when form (let ((parent (parent form))) (when (not (null parent)) (let ((new-offset (find-list-parent-offset parent fn))) (when new-offset - (setf (offset mark) new-offset))))) - (error 'no-expression)))) + (setf (offset mark) new-offset))))))))

-(defmethod backward-up-list (mark (syntax lisp-syntax)) +(defmethod backward-one-up (mark (syntax lisp-syntax)) (up-list-by-fn mark syntax #'start-offset))

-(defmethod up-list (mark (syntax lisp-syntax)) +(defmethod forward-one-up (mark (syntax lisp-syntax)) (up-list-by-fn mark syntax #'end-offset))

(defmethod eval-defun (mark (syntax lisp-syntax)) @@ -1911,7 +1920,7 @@ do (return (eval (read-from-string (token-string syntax form)))))))

-(defmethod beginning-of-definition (mark (syntax lisp-syntax)) +(defmethod backward-one-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) with last-toplevel-list = nil @@ -1925,15 +1934,18 @@ when (typep form 'form) do (setf last-toplevel-list form) finally (when last-toplevel-list form - (setf (offset mark) (start-offset last-toplevel-list)))))) + (setf (offset mark) + (start-offset last-toplevel-list)) + (return t)))))

-(defmethod end-of-definition (mark (syntax lisp-syntax)) +(defmethod forward-one-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) when (and (typep form 'form) (mark< mark (end-offset form))) do (setf (offset mark) (end-offset form)) - (loop-finish)))) + (loop-finish) + finally (return t))))

(defun in-type-p-in-children (children offset type) (loop for child in children --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/06/05 21:01:51 1.5 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/06/12 19:10:58 1.6 @@ -30,16 +30,26 @@

(in-package :climacs-lisp-syntax)

+;; Movement commands. +(climacs-motion-commands:define-motion-commands expression lisp-table) +(climacs-motion-commands:define-motion-commands definition lisp-table) +(climacs-motion-commands:define-motion-commands up lisp-table + :noun "nesting level up" + :plural "levels") +(climacs-motion-commands:define-motion-commands down lisp-table + :noun "nesting level down" + :plural "levels") +(climacs-motion-commands:define-motion-commands list lisp-table) + +(climacs-editing-commands:define-editing-commands expression lisp-table) +(climacs-editing-commands:define-deletion-commands expression lisp-table) + (define-command (com-eval-defun :name t :command-table lisp-table) () (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) (eval-defun point syntax)))

-(esa:set-key 'com-eval-defun - 'lisp-table - '((#\x :control :meta))) - (define-command (com-package :name t :command-table lisp-table) () (let* ((pane (current-window)) (syntax (syntax (buffer pane))) @@ -62,35 +72,74 @@ (when (typep token 'string-form) (with-accessors ((offset1 start-offset) (offset2 end-offset)) token - (fill-region (make-instance 'standard-right-sticky-mark - :buffer implementation - :offset offset1) - (make-instance 'standard-right-sticky-mark - :buffer implementation - :offset offset2) - #'(lambda (mark) - (syntax-line-indentation mark tab-width syntax)) - fill-column - tab-width - t))))) - -(esa:set-key 'com-fill-paragraph - 'lisp-table - '((#\q :meta))) + (climacs-editing:fill-region (make-instance 'standard-right-sticky-mark + :buffer implementation + :offset offset1) + (make-instance 'standard-right-sticky-mark + :buffer implementation + :offset offset2) + #'(lambda (mark) + (syntax-line-indentation mark tab-width syntax)) + fill-column + tab-width + syntax + t)))))

(define-command (com-indent-expression :name t :command-table lisp-table) ((count 'integer :prompt "Number of expressions")) (let* ((pane (current-window)) (point (point pane)) (mark (clone-mark point)) - (syntax (syntax (buffer pane))) - (view (stream-default-view pane)) - (tab-space-count (tab-space-count view))) + (syntax (syntax (buffer pane)))) (if (plusp count) (loop repeat count do (forward-expression mark syntax)) (loop repeat (- count) do (backward-expression mark syntax))) - (indent-region pane (clone-mark point) mark))) + (climacs-editing:indent-region pane (clone-mark point) mark))) + +(esa:set-key 'com-fill-paragraph + 'lisp-table + '((#\q :meta))) + +(esa:set-key 'com-eval-defun + 'lisp-table + '((#\x :control :meta)))

(esa:set-key `(com-indent-expression ,*numeric-argument-marker*) 'lisp-table - '((#\q :meta :control))) \ No newline at end of file + '((#\q :meta :control))) + +(esa:set-key `(com-backward-up ,*numeric-argument-marker*) + 'lisp-table + '((#\u :control :meta))) + +(esa:set-key `(com-forward-down ,*numeric-argument-marker*) + 'lisp-table + '((#\d :control :meta))) + +(esa:set-key `(com-backward-expression ,*numeric-argument-marker*) + 'lisp-table + '((#\b :control :meta))) + +(esa:set-key `(com-forward-expression ,*numeric-argument-marker*) + 'lisp-table + '((#\f :control :meta))) + +(esa:set-key `(com-backward-definition ,*numeric-argument-marker*) + 'lisp-table + '((#\a :control :meta))) + +(esa:set-key `(com-forward-definition ,*numeric-argument-marker*) + 'lisp-table + '((#\e :control :meta))) + +(esa:set-key `(com-forward-list ,*numeric-argument-marker*) + 'lisp-table + '((#\n :control :meta))) + +(esa:set-key `(com-backward-list ,*numeric-argument-marker*) + 'lisp-table + '((#\p :control :meta))) + +(esa:set-key `(com-kill-expression ,*numeric-argument-marker*) + 'lisp-table + '((#\k :control :meta))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/05/06 19:51:04 1.33 +++ /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/06/12 19:10:58 1.34 @@ -675,7 +675,7 @@ (incf valid-parse))))

(defmethod inter-lexeme-object-p ((lexer html-lexer) object) - (whitespacep object)) + (whitespacep (syntax (buffer lexer)) object))

(defmethod update-syntax (buffer (syntax html-syntax)) (with-slots (lexer valid-parse) syntax --- /project/climacs/cvsroot/climacs/gui.lisp 2006/06/04 16:27:18 1.217 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/06/12 19:10:58 1.218 @@ -311,8 +311,6 @@ (declare (ignore region)) (redisplay-frame-pane *application-frame* pane))

-(defvar *kill-ring* (make-instance 'kill-ring :max-size 7)) - (defmethod execute-frame-command :around ((frame climacs) command) (let ((current-window (car (windows frame)))) (handler-case --- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/05/06 19:51:04 1.3 +++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/06/12 19:10:58 1.4 @@ -192,12 +192,6 @@ ;;; ;;; exploit the parse

-(defmethod backward-expression (mark (syntax fundamental-syntax)) - nil) - -(defmethod forward-expression (mark (syntax fundamental-syntax)) - nil) - ;; do this better (defmethod syntax-line-indentation (mark tab-width (syntax fundamental-syntax)) 0) --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/06/01 22:51:40 1.19 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/06/12 19:10:58 1.20 @@ -177,7 +177,7 @@ (let ((scan (beginning-of-buffer (clone-mark (point buffer))))) ;; skip the leading whitespace (loop until (end-of-buffer-p scan) - until (not (whitespacep (object-after scan))) + until (not (whitespacep (syntax buffer) (object-after scan))) do (forward-object scan)) ;; stop looking if we're already 1,000 objects into the buffer (unless (> (offset scan) 1000) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/04/23 12:11:26 1.44 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/06/12 19:10:58 1.45 @@ -44,15 +44,17 @@

(:file "packages" :depends-on ("cl-automaton" "Persistent")) (:file "buffer" :depends-on ("packages")) + (:file "motion" :depends-on ("packages" "buffer" "syntax")) + (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring")) (:file "persistent-buffer" :pathname #p"Persistent/persistent-buffer.lisp" :depends-on ("packages" "buffer" "Persistent"))

- (:file "base" :depends-on ("packages" "buffer" "persistent-buffer")) + (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) (:file "io" :depends-on ("packages" "buffer")) (:file "abbrev" :depends-on ("packages" "buffer" "base")) (:file "syntax" :depends-on ("packages" "buffer" "base")) - (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax")) + (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax" "motion")) (:file "delegating-buffer" :depends-on ("packages" "buffer")) (:file "kill-ring" :depends-on ("packages")) (:file "undo" :depends-on ("packages")) @@ -72,12 +74,14 @@ "pane")) (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" "gui")) - (:file "lisp-syntax-commands" :depends-on ("lisp-syntax")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands")) (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "io" "text-syntax" - "abbrev" )) + "abbrev" "editing" "motion")) ;; (:file "buffer-commands" :depends-on ("gui")) (:file "developer-commands" :depends-on ("gui" "lisp-syntax")) + (:file "motion-commands" :depends-on ("gui")) + (:file "editing-commands" :depends-on ("gui")) (:file "file-commands" :depends-on ("gui")) (:file "misc-commands" :depends-on ("gui")) (:file "search-commands" :depends-on ("gui")) --- /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/05/06 19:51:04 1.18 +++ /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/06/12 19:10:58 1.19 @@ -1006,7 +1006,7 @@ (incf valid-parse))))

(defmethod inter-lexeme-object-p ((lexer cl-lexer) object) - (whitespacep object)) + (whitespacep (syntax (buffer lexer)) object))

(defmethod update-syntax (buffer (syntax cl-syntax)) (with-slots (lexer valid-parse) syntax @@ -1030,7 +1030,8 @@ (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (and (< start end) - (whitespacep (buffer-object buffer start))) + (whitespacep (syntax buffer) + (buffer-object buffer start))) do (ecase (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) --- /project/climacs/cvsroot/climacs/buffer.lisp 2006/04/30 15:20:46 1.33 +++ /project/climacs/cvsroot/climacs/buffer.lisp 2006/06/12 19:10:58 1.34 @@ -136,25 +136,17 @@ (:documentation "Move `mark' `count' objects backwards. Returns `mark'."))

-(defmethod backward-object :around (mark &optional count) - (declare (ignore count)) - (call-next-method) - mark) - -(defmethod backward-object ((mark mark-mixin) &optional (count 1)) - (decf (offset mark) count)) - (defgeneric forward-object (mark &optional count) (:documentation "Move `mark' `count' objects forwards. Returns `mark'"))

-(defmethod forward-object :around (mark &optional count) - (declare (ignore count)) - (call-next-method) - mark) - (defmethod forward-object ((mark mark-mixin) &optional (count 1)) - (incf (offset mark) count)) + (incf (offset mark) count) + t) + +(defmethod backward-object ((mark mark-mixin) &optional (count 1)) + (decf (offset mark) count) + t)

(defclass standard-left-sticky-mark (left-sticky-mark mark-mixin) () (:documentation "A left-sticky-mark subclass suitable for use in a standard-buffer")) @@ -377,7 +369,7 @@

(defmethod beginning-of-line ((mark mark-mixin)) (loop until (beginning-of-line-p mark) - do (decf (offset mark)))) + do (backward-object mark)))

(defgeneric end-of-line (mark) (:documentation "Move the mark to the end of the line. The mark will be positioned @@ -432,6 +424,15 @@ (defmethod column-number ((mark mark-mixin)) (buffer-column-number (buffer mark) (offset mark)))

+(defgeneric (setf column-number) (number mark) + (:documentation "Set the column number of the mark.")) + +(defmethod (setf column-number) (number mark) + (beginning-of-line mark) + (loop repeat number + until (end-of-line-p mark) + do (incf (offset mark)))) + (defgeneric insert-buffer-object (buffer offset object) (:documentation "Insert the object at the offset in the buffer. Any left-sticky marks that are placed at the offset will remain positioned before the --- /project/climacs/cvsroot/climacs/base.lisp 2006/06/05 21:01:51 1.50 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/06/12 19:10:58 1.51 @@ -63,71 +63,6 @@ (unless (end-of-buffer-p ,mark-sym) (forward-object ,mark-sym)))))))

-(defmethod previous-line (mark &optional column (count 1)) - "Move a mark up COUNT lines conserving horizontal position." - (unless column - (setf column (column-number mark))) - (loop repeat count - do (beginning-of-line mark) - until (beginning-of-buffer-p mark) - do (backward-object mark)) - (end-of-line mark) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column))) - -(defmethod previous-line ((mark p-line-mark-mixin) &optional column (count 1)) - "Move a mark up COUNT lines conserving horizontal position." - (unless column - (setf column (column-number mark))) - (let* ((line (line-number mark)) - (goto-line (max 0 (- line count)))) - (setf (offset mark) - (+ column (buffer-line-offset (buffer mark) goto-line))))) - -(defmethod next-line (mark &optional column (count 1)) - "Move a mark down COUNT lines conserving horizontal position." - (unless column - (setf column (column-number mark))) - (loop repeat count - do (end-of-line mark) - until (end-of-buffer-p mark) - do (forward-object mark)) - (end-of-line mark) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column))) - -(defmethod next-line ((mark p-line-mark-mixin) &optional column (count 1)) - "Move a mark down COUNT lines conserving horizontal position." - (unless column - (setf column (column-number mark))) - (let* ((line (line-number mark)) - (goto-line (min (number-of-lines (buffer mark)) - (+ line count)))) - (setf (offset mark) - (+ column (buffer-line-offset (buffer mark) goto-line))))) - -(defmethod open-line ((mark left-sticky-mark) &optional (count 1)) - "Create a new line in a buffer after the mark." - (loop repeat count - do (insert-object mark #\Newline))) - -(defmethod open-line ((mark right-sticky-mark) &optional (count 1)) - "Create a new line in a buffer after the mark." - (loop repeat count - do (insert-object mark #\Newline) - (decf (offset mark)))) - -(defun kill-line (mark) - "Remove a line from a buffer." - (if (end-of-line-p mark) - (unless (end-of-buffer-p mark) - (delete-range mark)) - (let ((offset (offset mark))) - (end-of-line mark) - (delete-region offset mark)))) - (defun empty-line-p (mark) "Check whether the mark is in an empty line." (and (beginning-of-line-p mark) (end-of-line-p mark))) @@ -204,60 +139,6 @@ #: #< #= #> #? #@ #^ #~ #_ #{ #} #[ #] )))))

-(defun whitespacep (obj) - "A predicate to ensure that an object is a whitespace character." - (and (characterp obj) - (member obj '(#\Space #\Tab #\Newline #\Page #\Return)))) - -(defun forward-to-word-boundary (mark) - "Move the mark forward to the beginning of the next word." - (loop until (end-of-buffer-p mark) - until (constituentp (object-after mark)) - do (incf (offset mark)))) - -(defun backward-to-word-boundary (mark) - "Move the mark backward to the end of the previous word." - (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) - do (decf (offset mark)))) - -(defun forward-word (mark &optional (count 1)) - "Forward the mark to the next word." - (loop repeat count - do (forward-to-word-boundary mark) - (loop until (end-of-buffer-p mark) - while (constituentp (object-after mark)) - do (incf (offset mark))))) - -(defun backward-word (mark &optional (count 1)) - "Shuttle the mark to the start of the previous word." - (loop repeat count - do (backward-to-word-boundary mark) - (loop until (beginning-of-buffer-p mark) - while (constituentp (object-before mark)) - do (decf (offset mark))))) - -(defun delete-word (mark &optional (count 1)) - "Delete until the end of the word" - (let ((mark2 (clone-mark mark))) - (forward-word mark2 count) - (delete-region mark mark2))) - -(defun backward-delete-word (mark &optional (count 1)) - "Delete until the beginning of the word" - (let ((mark2 (clone-mark mark))) - (backward-word mark2 count) - (delete-region mark mark2))) - -(defun previous-word (mark) - "Return a freshly allocated sequence, that is word before the mark" - (region-to-sequence - (loop for i downfrom (offset mark) - while (and (plusp i) - (constituentp (buffer-object (buffer mark) (1- i)))) - finally (return i)) - mark)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case @@ -285,325 +166,6 @@ (possibly-capitalized :capitalized) (t nil))))

-;;; I'd rather have update-buffer-range methods spec. on buffer for this, -;;; for performance and history-size reasons --amb -(defun downcase-buffer-region (buffer offset1 offset2) - (do-buffer-region (object offset buffer offset1 offset2) - (when (and (constituentp object) (upper-case-p object)) - (setf object (char-downcase object))))) - -(defgeneric downcase-region (mark1 mark2) - (:documentation "Convert all characters after mark1 and before mark2 to -lowercase. An error is signaled if the two marks are positioned in different -buffers. It is acceptable to pass an offset in place of one of the marks.")) - -(defmethod downcase-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod downcase-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod downcase-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) - -(defun downcase-word (mark &optional (n 1)) - "Convert the next N words to lowercase, leaving mark after the last word." - (loop repeat n - do (forward-to-word-boundary mark) - (let ((offset (offset mark))) - (forward-word mark) - (downcase-region offset mark)))) - -(defun upcase-buffer-region (buffer offset1 offset2) - (do-buffer-region (object offset buffer offset1 offset2) - (when (and (constituentp object) (lower-case-p object)) - (setf object (char-upcase object))))) - -(defgeneric upcase-region (mark1 mark2) - (:documentation "Convert all characters after mark1 and before mark2 to -uppercase. An error is signaled if the two marks are positioned in different -buffers. It is acceptable to pass an offset in place of one of the marks.")) - -(defmethod upcase-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod upcase-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod upcase-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) - -(defun upcase-word (mark &optional (n 1)) - "Convert the next N words to uppercase, leaving mark after the last word." - (loop repeat n - do (forward-to-word-boundary mark) - (let ((offset (offset mark))) - (forward-word mark) - (upcase-region offset mark)))) - -(defun capitalize-buffer-region (buffer offset1 offset2) - (let ((previous-char-constituent-p nil)) - (do-buffer-region (object offset buffer offset1 offset2) - (when (constituentp object) - (if previous-char-constituent-p - (when (upper-case-p object) - (setf object (char-downcase object))) - (when (lower-case-p object) - (setf object (char-upcase object))))) - (setf previous-char-constituent-p (constituentp object))))) - -(defgeneric capitalize-region (mark1 mark2) - (:documentation "Capitalize all words after mark1 and before mark2. -An error is signaled if the two marks are positioned in different buffers. -It is acceptable to pass an offset in place of one of the marks.")) - -(defmethod capitalize-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod capitalize-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod capitalize-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) - -(defun capitalize-word (mark &optional (n 1)) - "Capitalize the next N words, leaving mark after the last word." - (loop repeat n - do (forward-to-word-boundary mark) - (let ((offset (offset mark))) - (forward-word mark) - (capitalize-region offset mark)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Tabify - -(defun tabify-buffer-region (buffer offset1 offset2 tab-width) - (flet ((looking-at-spaces (buffer offset count) - (loop for i from offset - repeat count - unless (char= (buffer-object buffer i) #\Space) - return nil - finally (return t)))) - (loop for offset = offset1 then (1+ offset) - until (>= offset offset2) - do (let* ((column (buffer-display-column - buffer offset tab-width)) - (count (- tab-width (mod column tab-width)))) - (when (looking-at-spaces buffer offset count) - (finish-output) - (delete-buffer-range buffer offset count) - (insert-buffer-object buffer offset #\Tab) - (decf offset2 (1- count))))))) - -(defgeneric tabify-region (mark1 mark2 tab-width) - (:documentation "Replace sequences of tab-width spaces with tabs -in the region delimited by mark1 and mark2.")) - -(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) - -(defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defun untabify-buffer-region (buffer offset1 offset2 tab-width) - (loop for offset = offset1 then (1+ offset) - until (>= offset offset2) - when (char= (buffer-object buffer offset) #\Tab) - do (let* ((column (buffer-display-column buffer - offset - tab-width)) - (count (- tab-width (mod column tab-width)))) - (delete-buffer-range buffer offset 1) - (loop repeat count - do (insert-buffer-object buffer offset #\Space)) - (incf offset (1- count)) - (incf offset2 (1- count))))) - -(defgeneric untabify-region (mark1 mark2 tab-width) - (:documentation "Replace tabs with tab-width spaces in the region -delimited by mark1 and mark2.")) - -(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) - -(defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Indentation - -(defgeneric indent-line (mark indentation tab-width) - (:documentation "Indent the line containing mark with indentation -spaces. Use tabs and spaces if tab-width is not nil, otherwise use -spaces only.")) - -(defun indent-line* (mark indentation tab-width left) - (let ((mark2 (clone-mark mark))) - (beginning-of-line mark2) - (loop until (end-of-buffer-p mark2) - as object = (object-after mark2) - while (or (eql object #\Space) (eql object #\Tab)) - do (delete-range mark2 1)) - (loop until (zerop indentation) - do (cond ((and tab-width (>= indentation tab-width)) - (insert-object mark2 #\Tab) - (when left ; spaces must follow tabs - (forward-object mark2)) - (decf indentation tab-width)) - (t - (insert-object mark2 #\Space) - (decf indentation)))))) - -(defmethod indent-line ((mark left-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width t)) - -(defmethod indent-line ((mark right-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width nil)) - -(defun delete-indentation (mark) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (delete-range mark -1) - (loop until (end-of-buffer-p mark) - while (whitespacep (object-after mark)) - do (delete-range mark 1)) - (loop until (beginning-of-buffer-p mark) - while (whitespacep (object-before mark)) - do (delete-range mark -1)) - (when (and (not (beginning-of-buffer-p mark)) - (constituentp (object-before mark))) - (insert-object mark #\Space)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Auto fill - -(defun fill-line (mark syntax-line-indentation-function fill-column tab-width - &optional (compress-whitespaces t)) - "Breaks the contents of line pointed to by MARK up to MARK into -multiple lines such that none of them is longer than FILL-COLUMN. If -COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the

[84 lines skipped]

--- /project/climacs/cvsroot/climacs/motion.lisp 2006/06/12 19:10:59 NONE +++ /project/climacs/cvsroot/climacs/motion.lisp 2006/06/12 19:10:59 1.1

[589 lines skipped] --- /project/climacs/cvsroot/climacs/motion-commands.lisp 2006/06/12 19:10:59 NONE +++ /project/climacs/cvsroot/climacs/motion-commands.lisp 2006/06/12 19:10:59 1.1

[803 lines skipped] --- /project/climacs/cvsroot/climacs/editing.lisp 2006/06/12 19:10:59 NONE +++ /project/climacs/cvsroot/climacs/editing.lisp 2006/06/12 19:10:59 1.1

[1427 lines skipped] --- /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/06/12 19:10:59 NONE +++ /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/06/12 19:10:59 1.1

[1676 lines skipped]