[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Mon Jun 12 19:10:59 UTC 2006
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]
More information about the Climacs-cvs
mailing list