[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Mon Jul 24 13:24:41 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv2300
Modified Files:
window-commands.lisp search-commands.lisp pane.lisp
packages.lisp misc-commands.lisp lisp-syntax-commands.lisp
gui.lisp file-commands.lisp editing.lisp
developer-commands.lisp climacs.asd buffer-test.lisp base.lisp
Log Message:
Final major package-cleanup for now. New package, CLIMACS-CORE,
added. Lots of commands moved from CLIMACS-GUI to CLIMACS-COMMANDS,
reusable functions moved to CLIMACS-CORE.
--- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/05/13 17:19:10 1.8
+++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 13:24:40 1.9
@@ -26,7 +26,7 @@
;;; Windows commands for the Climacs editor.
-(in-package :climacs-gui)
+(in-package :climacs-commands)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
--- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/02 18:42:28 1.8
+++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 13:24:40 1.9
@@ -26,7 +26,7 @@
;;; Search commands for the Climacs editor.
-(in-package :climacs-gui)
+(in-package :climacs-commands)
(defun display-string (string)
(with-output-to-string (result)
@@ -329,7 +329,9 @@
with length = (length string)
with use-region-case = (no-upper-p string)
for occurrences from 0
- while (query-replace-find-next-match point string)
+ while (let ((offset-before (offset point)))
+ (search-forward point string :test (case-relevant-test string))
+ (/= (offset point) offset-before))
do (backward-object point length)
(replace-one-string point length newstring use-region-case)
finally (display-message "Replaced ~A occurrence~:P" occurrences))))
@@ -340,10 +342,19 @@
(make-command-table 'query-replace-climacs-table :errorp nil)
-(defun query-replace-find-next-match (mark string)
- (let ((offset-before (offset mark)))
- (search-forward mark string :test (case-relevant-test string))
- (/= (offset mark) offset-before)))
+(defun query-replace-find-next-match (state)
+ (with-accessors ((string string1)
+ (buffers buffers)
+ (mark mark)) state
+ (let ((offset-before (offset mark)))
+ (search-forward mark string :test (case-relevant-test string))
+ (or (/= (offset mark) offset-before)
+ (unless (null (rest buffers))
+ (pop buffers)
+ (switch-to-buffer (first buffers))
+ (setf mark (point (first buffers)))
+ (beginning-of-buffer mark)
+ (query-replace-find-next-match state))))))
(define-command (com-query-replace :name t :command-table search-table) ()
(let* ((pane (current-window))
@@ -375,11 +386,13 @@
(point (point pane))
(occurrences 0))
(declare (special string1 string2 occurrences))
- (when (query-replace-find-next-match point string1)
- (setf (query-replace-state pane) (make-instance 'query-replace-state
- :string1 string1
- :string2 string2)
- (query-replace-mode pane) t)
+ (setf (query-replace-state pane) (make-instance 'query-replace-state
+ :string1 string1
+ :string2 string2
+ :mark point
+ :buffers (list (buffer pane))))
+ (when (query-replace-find-next-match (query-replace-state pane))
+ (setf (query-replace-mode pane) t)
(display-message "Replace ~A with ~A:"
string1 string2)
(simple-command-loop 'query-replace-climacs-table
@@ -394,12 +407,15 @@
(define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) ()
(declare (special string1 string2 occurrences))
(let* ((pane (current-window))
- (point (point pane))
- (string1-length (length string1)))
- (backward-object point string1-length)
- (replace-one-string point string1-length string2 (no-upper-p string1))
+ (string1-length (length string1))
+ (state (query-replace-state pane)))
+ (backward-object (mark state) string1-length)
+ (replace-one-string (mark state)
+ string1-length
+ string2
+ (no-upper-p string1))
(incf occurrences)
- (if (query-replace-find-next-match point string1)
+ (if (query-replace-find-next-match (query-replace-state pane))
(display-message "Replace ~A with ~A:"
string1 string2)
(setf (query-replace-mode pane) nil))))
@@ -410,10 +426,13 @@
()
(declare (special string1 string2 occurrences))
(let* ((pane (current-window))
- (point (point pane))
- (string1-length (length string1)))
- (backward-object point string1-length)
- (replace-one-string point string1-length string2 (no-upper-p string1))
+ (string1-length (length string1))
+ (state (query-replace-state pane)))
+ (backward-object (mark state) string1-length)
+ (replace-one-string (mark state)
+ string1-length
+ string2
+ (no-upper-p string1))
(incf occurrences)
(setf (query-replace-mode pane) nil)))
@@ -423,19 +442,21 @@
()
(declare (special string1 string2 occurrences))
(let* ((pane (current-window))
- (point (point pane))
- (string1-length (length string1)))
- (loop do (backward-object point string1-length)
- (replace-one-string point string1-length string2 (no-upper-p string1))
- (incf occurrences)
- while (query-replace-find-next-match point string1)
- finally (setf (query-replace-mode pane) nil))))
+ (string1-length (length string1))
+ (state (query-replace-state pane)))
+ (loop do (backward-object (mark state) string1-length)
+ (replace-one-string (mark state)
+ string1-length
+ string2
+ (no-upper-p string1))
+ (incf occurrences)
+ while (query-replace-find-next-match (query-replace-state pane))
+ finally (setf (query-replace-mode pane) nil))))
(define-command (com-query-replace-skip :name t :command-table query-replace-climacs-table) ()
(declare (special string1 string2))
- (let* ((pane (current-window))
- (point (point pane)))
- (if (query-replace-find-next-match point string1)
+ (let ((pane (current-window)))
+ (if (query-replace-find-next-match (query-replace-state pane))
(display-message "Replace ~A with ~A:"
string1 string2)
(setf (query-replace-mode pane) nil))))
@@ -694,4 +715,4 @@
(multiple-query-replace-set-key '(#\y) 'com-multiple-query-replace-replace)
(multiple-query-replace-set-key '(#\n) 'com-multiple-query-replace-skip)
(multiple-query-replace-set-key '(#\.) 'com-multiple-query-replace-replace-and-quit)
-(multiple-query-replace-set-key '(#\!) 'com-multiple-query-replace-replace-all)
\ No newline at end of file
+(multiple-query-replace-set-key '(#\!) 'com-multiple-query-replace-replace-all)
--- /project/climacs/cvsroot/climacs/pane.lisp 2006/07/21 06:25:45 1.45
+++ /project/climacs/cvsroot/climacs/pane.lisp 2006/07/24 13:24:40 1.46
@@ -183,7 +183,9 @@
(defclass query-replace-state ()
((string1 :initarg :string1 :accessor string1)
- (string2 :initarg :string2 :accessor string2)))
+ (string2 :initarg :string2 :accessor string2)
+ (buffers :initarg :buffers :accessor buffers)
+ (mark :initarg :mark :accessor mark)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/23 11:59:38 1.105
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 13:24:40 1.106
@@ -88,7 +88,6 @@
#:constituentp
#:just-n-spaces
#:buffer-whitespacep
- #:forward-word #:backward-word
#:buffer-region-case
#:input-from-stream #:output-to-stream
#:name-mixin #:name
@@ -101,7 +100,6 @@
#:upcase-buffer-region #:upcase-region
#:capitalize-buffer-region #:capitalize-region
#:tabify-region #:untabify-region
- #:indent-line #:delete-indentation
#:*kill-ring*)
(:documentation "Basic functionality built on top of the buffer
protocol. Here is where we define slightly higher level
@@ -186,7 +184,7 @@
#:isearch-state #:search-string #:search-mark
#:search-forward-p #:search-success-p
#:isearch-mode #:isearch-states #:isearch-previous-string
- #:query-replace-state #:string1 #:string2
+ #:query-replace-state #:string1 #:string2 #:buffers #:mark
#:query-replace-mode
#:region-visible-p
#:with-undo
@@ -302,14 +300,7 @@
;; Sentences
#:forward-delete-sentence #:backward-delete-sentence
#:forward-kill-sentence #:backward-kill-sentence
- #:transpose-sentences
-
-
- #:downcase-word #:upcase-word #:capitalize-word
-
- #:indent-region
- #:fill-line
- #:fill-region)
+ #:transpose-sentences)
(:documentation "Functions and facilities for changing the
buffer contents by syntactical elements. The functions in this package
are syntax-aware, and their behavior is based on the semantics
@@ -318,51 +309,87 @@
to implement the editing commands."))
(defpackage :climacs-gui
- (:use :clim-lisp :clim :climacs-buffer :climacs-base
- :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 ; Frame.
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base
+ :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 ; Frame.
+
+ #:extended-pane
+ #:climacs-info-pane
- ;; GUI functions follow.
- #:current-window
- #:current-point
- #:current-buffer
- #:current-buffer
- #:point
- #:syntax
- #:mark
- #: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
+ ;; GUI functions follow.
+ #:current-window
+ #:current-point
+ #:current-buffer
+ #:current-point
+ #:point
+ #:syntax
+ #:mark
+ #:insert-character
+ #:switch-to-buffer
+ #:make-buffer
+ #:erase-buffer
+ #:buffer-pane-p
+ #:display-window
- ;; Some configuration variables
- #:*bg-color*
- #:*fg-color*
- #:*info-bg-color*
- #:*info-fg-color*
- #:*mini-bg-color*
- #:*mini-fg-color*))
+ ;; Some configuration variables
+ #:*bg-color*
+ #:*fg-color*
+ #:*info-bg-color*
+ #:*info-fg-color*
+ #:*mini-bg-color*
+ #:*mini-fg-color*
+ #:*with-scrollbars*
+
+ ;; The command tables
+ #:global-climacs-table #:keyboard-macro-table #:climacs-help-table
+ #: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
+
+ ;; Other stuff
+ #:dabbrev-expansion-mark
+ #:original-prefix
+ #:prefix-start-offset
+ #:overwrite-mode
+ #:goal-column
+ ))
+
+(defpackage :climacs-core
+ (:use :clim-lisp :climacs-base :climacs-buffer
+ :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring
+ :climacs-editing :climacs-gui :clim :climacs-abbrev)
+ (:export #:goto-position
+ #:goto-line
+
+ #:possibly-fill-line
+ #:insert-character
+ #:back-to-indentation
+ #:delete-horizontal-space
+ #:indent-current-line
+ #:insert-pair
+
+ #:downcase-word #:upcase-word #:capitalize-word
+
+ #:indent-region
+ #:fill-line #:fill-region
+
+ #:indent-line #:delete-indentation)
+ (:documentation "Package for editor functionality that is
+ syntax-aware, but yet not specific to certain
+ syntaxes. Contains stuff like indentation, filling and other
+ features that require a fairly high-level view of the
+ application, but are not solely GUI-specific."))
(defpackage :climacs-commands
(:use :clim-lisp :clim :climacs-base :climacs-buffer
:climacs-syntax :climacs-motion :climacs-editing
- :climacs-gui :esa :climacs-kill-ring)
+ :climacs-gui :esa :climacs-kill-ring :climacs-pane
+ :climacs-abbrev :undo :climacs-core)
(:export #:define-motion-commands
#:define-deletion-commands
#:define-editing-commands)
--- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/02 15:43:48 1.16
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 13:24:40 1.17
@@ -26,7 +26,7 @@
;;; miscellaneous commands for the Climacs editor.
-(in-package :climacs-gui)
+(in-package :climacs-commands)
(define-command (com-overwrite-mode :name t :command-table editing-table) ()
"Toggle overwrite mode for the current mode.
@@ -52,6 +52,11 @@
'buffer-table
'((#\~ :meta :shift)))
+(defun set-fill-column (column)
+ (if (> column 1)
+ (setf (auto-fill-column (current-window)) column)
+ (progn (beep) (display-message "Set Fill Column requires an explicit argument."))))
+
(define-command (com-set-fill-column :name t :command-table fill-table)
((column 'integer :prompt "Column Number:"))
"Set the fill column to the specified value.
@@ -65,45 +70,6 @@
'fill-table
'((#\x :control) (#\f)))
-(defun set-fill-column (column)
- (if (> column 1)
- (setf (auto-fill-column (current-window)) column)
- (progn (beep) (display-message "Set Fill Column requires an explicit argument."))))
-
-(defun possibly-fill-line ()
- (let* ((pane (current-window))
- (buffer (buffer pane)))
- (when (auto-fill-mode pane)
- (let* ((fill-column (auto-fill-column pane))
- (point (point pane))
- (offset (offset point))
- (tab-width (tab-space-count (stream-default-view pane)))
- (syntax (syntax buffer)))
- (when (>= (buffer-display-column buffer offset tab-width)
- (1- fill-column))
- (fill-line point
- (lambda (mark)
- (syntax-line-indentation mark tab-width syntax))
- fill-column
- tab-width
- (syntax buffer)))))))
-
-(defun insert-character (char)
- (let* ((window (current-window))
- (point (point window)))
- (unless (constituentp char)
- (possibly-expand-abbrev point))
- (when (whitespacep (syntax (buffer window)) char)
- (possibly-fill-line))
- (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point)))
- (progn
- (delete-range point)
- (insert-object point char))
- (insert-object point char))))
-
-(define-command com-self-insert ((count 'integer))
- (loop repeat count do (insert-character *current-gesture*)))
-
(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."
@@ -271,16 +237,6 @@
(untabify-region
(mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
-(defun indent-current-line (pane point)
- (let* ((buffer (buffer pane))
- (view (stream-default-view pane))
- (tab-space-count (tab-space-count view))
- (indentation (syntax-line-indentation point
- tab-space-count
- (syntax buffer))))
- (indent-line point indentation (and (indent-tabs-mode buffer)
- tab-space-count))))
-
(define-command (com-indent-line :name t :command-table indent-table) ()
(let* ((pane (current-window))
(point (point pane)))
@@ -410,12 +366,6 @@
'marking-table
'((#\x :control) (#\h)))
-(defun back-to-indentation (mark syntax)
- (beginning-of-line mark)
- (loop until (end-of-line-p mark)
- while (whitespacep syntax (object-after mark))
- do (forward-object mark)))
-
(define-command (com-back-to-indentation :name t :command-table movement-table) ()
"Move point to the first non-whitespace object on the current line.
If there is no non-whitespace object, leaves point at the end of the line."
@@ -426,17 +376,6 @@
'movement-table
'((#\m :meta)))
-(defun delete-horizontal-space (mark syntax &optional (backward-only-p nil))
- (let ((mark2 (clone-mark mark)))
- (loop until (beginning-of-line-p mark)
- while (whitespacep syntax (object-before mark))
- do (backward-object mark))
- (unless backward-only-p
- (loop until (end-of-line-p mark2)
- while (whitespacep syntax (object-after mark2))
- do (forward-object mark2)))
- (delete-region mark mark2)))
-
(define-command (com-delete-horizontal-space :name t :command-table deletion-table)
((backward-only-p
'boolean :prompt "Delete backwards only?"))
@@ -450,37 +389,19 @@
'deletion-table
'((#\\ :meta)))
-(defun just-one-space (mark syntax count)
- (let (offset)
- (loop until (beginning-of-line-p mark)
- while (whitespacep syntax (object-before mark))
- do (backward-object mark))
- (loop until (end-of-line-p mark)
- while (whitespacep syntax (object-after mark))
- repeat count do (forward-object mark)
- finally (setf offset (offset mark)))
- (loop until (end-of-line-p mark)
- while (whitespacep syntax (object-after mark))
- do (forward-object mark))
- (delete-region offset mark)))
-
(define-command (com-just-one-space :name t :command-table deletion-table)
((count 'integer :prompt "Number of spaces"))
"Delete whitespace around point, leaving a single space.
With a positive numeric argument, leave that many spaces.
FIXME: should distinguish between types of whitespace."
- (just-one-space (point (current-window))
- (syntax (buffer (current-window)))
- count))
+ (just-n-spaces (point (current-window))
+ count))
(set-key `(com-just-one-space ,*numeric-argument-marker*)
'deletion-table
'((#\Space :meta)))
-(defun goto-position (mark pos)
- (setf (offset mark) pos))
-
(define-command (com-goto-position :name t :command-table movement-table)
((position 'integer :prompt "Goto Position"))
"Prompts for an integer, and sets the offset of point to that integer."
@@ -488,18 +409,6 @@
(point (current-window))
position))
-(defun goto-line (mark line-number)
- (loop with m = (clone-mark (low-mark (buffer mark))
- :right)
- initially (beginning-of-buffer m)
- do (end-of-line m)
- until (end-of-buffer-p m)
- repeat (1- line-number)
- do (incf (offset m))
- (end-of-line m)
- finally (beginning-of-line m)
- (setf (offset mark) (offset m))))
-
(define-command (com-goto-line :name t :command-table movement-table)
((line-number 'integer :prompt "Goto Line"))
"Prompts for a line number, and sets point to the beginning of that line.
@@ -671,7 +580,9 @@
(let* ((window (current-window))
(point (point window))
(syntax (syntax (buffer window))))
- (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) window
+ (with-accessors ((original-prefix original-prefix)
+ (prefix-start-offset prefix-start-offset)
+ (dabbrev-expansion-mark dabbrev-expansion-mark)) window
(flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
(setf (offset dabbrev-expansion-mark)
(offset point))
@@ -829,26 +740,6 @@
;; (defparameter *insert-pair-alist*
;; '((#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) (#\" #\") (#\' #\') (#\` #\')))
-(defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\)))
- (cond ((> count 0)
- (loop while (and (not (end-of-buffer-p mark))
- (whitespacep syntax (object-after mark)))
- do (forward-object mark)))
- ((< count 0)
- (setf count (- count))
- (loop repeat count do (backward-expression mark syntax))))
- (unless (or (beginning-of-buffer-p mark)
- (whitespacep syntax (object-before mark)))
- (insert-object mark #\Space))
- (insert-object mark open)
- (let ((here (clone-mark mark)))
- (loop repeat count
- do (forward-expression here syntax))
- (insert-object here close)
- (unless (or (end-of-buffer-p here)
- (whitespacep syntax (object-after here)))
- (insert-object here #\Space))))
-
(defun insert-parentheses (mark syntax count)
(insert-pair mark syntax count #\( #\)))
--- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/24 08:20:28 1.11
+++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/24 13:24:40 1.12
@@ -72,7 +72,7 @@
(when (typep token 'string-form)
(with-accessors ((offset1 start-offset)
(offset2 end-offset)) token
- (climacs-editing:fill-region (make-instance 'standard-right-sticky-mark
+ (climacs-core:fill-region (make-instance 'standard-right-sticky-mark
:buffer implementation
:offset offset1)
(make-instance 'standard-right-sticky-mark
@@ -94,7 +94,7 @@
(if (plusp count)
(loop repeat count do (forward-expression mark syntax))
(loop repeat (- count) do (backward-expression mark syntax)))
- (climacs-editing:indent-region pane (clone-mark point) mark)))
+ (climacs-core:indent-region pane (clone-mark point) mark)))
(define-command (com-eval-last-expression :name t :command-table lisp-table)
((insertp 'boolean :prompt "Insert?"))
@@ -106,7 +106,7 @@
(with-syntax-package syntax mark (package)
(let ((*package* package)
(*read-base* (base syntax)))
- (climacs-gui::com-eval-expression
+ (climacs-commands::com-eval-expression
(token-to-object syntax token :read t)
insertp)))
(esa:display-message "Nothing to evaluate."))))
--- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/22 20:35:06 1.222
+++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 13:24:40 1.223
@@ -30,12 +30,12 @@
(defclass extended-pane (climacs-pane esa-pane-mixin)
(;; for next-line and previous-line commands
- (goal-column :initform nil)
+ (goal-column :initform nil :accessor goal-column)
;; for dynamic abbrev expansion
- (original-prefix :initform nil)
- (prefix-start-offset :initform nil)
- (dabbrev-expansion-mark :initform nil)
- (overwrite-mode :initform nil)))
+ (original-prefix :initform nil :accessor original-prefix)
+ (prefix-start-offset :initform nil :accessor prefix-start-offset)
+ (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark)
+ (overwrite-mode :initform nil :accessor overwrite-mode)))
(defgeneric buffer-pane-p (pane)
(:documentation "Returns T when a pane contains a buffer."))
@@ -128,7 +128,6 @@
(define-application-frame climacs (standard-application-frame
esa-frame-mixin)
((buffers :initform '() :accessor buffers))
-
(:command-table (global-climacs-table
:inherit-from (global-esa-table
keyboard-macro-table
@@ -369,6 +368,9 @@
'base-table
'((#\c :control) (#\l :control)))
+(define-command com-self-insert ((count 'integer))
+ (loop repeat count do (insert-character *current-gesture*)))
+
(loop for code from (char-code #\Space) to (char-code #\~)
do (set-key `(com-self-insert ,*numeric-argument-marker*)
'self-insert-table
--- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/06/12 19:10:58 1.20
+++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/07/24 13:24:40 1.21
@@ -26,7 +26,7 @@
;;; File commands for the Climacs editor.
-(in-package :climacs-gui)
+(in-package :climacs-commands)
(defun filename-completer (so-far mode)
(flet ((remove-trail (s)
--- /project/climacs/cvsroot/climacs/editing.lisp 2006/07/21 05:08:26 1.3
+++ /project/climacs/cvsroot/climacs/editing.lisp 2006/07/24 13:24:40 1.4
@@ -264,126 +264,3 @@
(define-edit-fns expression)
(define-edit-fns definition)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Character case
-
-(defun downcase-word (mark &optional (n 1))
- "Convert the next N words to lowercase, leaving mark after the last word."
- (let ((syntax (syntax (buffer mark))))
- (loop repeat n
- do (forward-to-word-boundary mark syntax)
- (let ((offset (offset mark)))
- (forward-word mark syntax 1 nil)
- (downcase-region offset mark)))))
-
-(defun upcase-word (mark syntax &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 syntax)
- (let ((offset (offset mark)))
- (forward-word mark syntax 1 nil)
- (upcase-region offset mark))))
-
-(defun capitalize-word (mark &optional (n 1))
- "Capitalize the next N words, leaving mark after the last word."
- (let ((syntax (syntax (buffer mark))))
- (loop repeat n
- do (forward-to-word-boundary mark syntax)
- (let ((offset (offset mark)))
- (forward-word mark syntax 1 nil)
- (capitalize-region offset mark)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Indentation
-
-(defun indent-region (pane mark1 mark2)
- "Indent all lines in the region delimited by `mark1' and `mark2'
- according to the rules of the active syntax in `pane'."
- (let* ((buffer (buffer pane))
- (view (clim:stream-default-view pane))
- (tab-space-count (tab-space-count view))
- (tab-width (and (indent-tabs-mode buffer)
- tab-space-count))
- (syntax (syntax buffer)))
- (do-buffer-region-lines (line mark1 mark2)
- (let ((indentation (syntax-line-indentation
- line
- tab-space-count
- syntax)))
- (indent-line line indentation tab-width))
- ;; We need to update the syntax every time we perform an
- ;; indentation, so that subsequent indentations will be
- ;; correctly indented (this matters in list forms). FIXME: This
- ;; should probably happen automatically.
- (update-syntax buffer syntax))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Auto fill
-
-(defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax
- &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
-decision is made to break the line at a point. For now, the
-compression means just the deletion of trailing whitespaces."
- (let ((begin-mark (clone-mark mark)))
- (beginning-of-line begin-mark)
- (loop with column = 0
- with line-beginning-offset = (offset begin-mark)
- with walking-mark = (clone-mark begin-mark)
- while (mark< walking-mark mark)
- as object = (object-after walking-mark)
- do (case object
- (#\Space
- (setf (offset begin-mark) (offset walking-mark))
- (incf column))
- (#\Tab
- (setf (offset begin-mark) (offset walking-mark))
- (incf column (- tab-width (mod column tab-width))))
- (t
- (incf column)))
- (when (and (>= column fill-column)
- (/= (offset begin-mark) line-beginning-offset))
- (when compress-whitespaces
- (let ((offset (buffer-search-backward
- (buffer begin-mark)
- (offset begin-mark)
- #(nil)
- :test #'(lambda (o1 o2)
- (declare (ignore o2))
- (not (whitespacep syntax o1))))))
- (when offset
- (delete-region begin-mark (1+ offset)))))
- (insert-object begin-mark #\Newline)
- (incf (offset begin-mark))
- (let ((indentation
- (funcall syntax-line-indentation-function begin-mark)))
- (indent-line begin-mark indentation tab-width))
- (beginning-of-line begin-mark)
- (setf line-beginning-offset (offset begin-mark))
- (setf (offset walking-mark) (offset begin-mark))
- (setf column 0))
- (incf (offset walking-mark)))))
-
-(defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax
- &optional (compress-whitespaces t))
- "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be
-mark<= `mark2.'"
- (let* ((buffer (buffer mark1)))
- (do-buffer-region (object offset buffer
- (offset mark1) (offset mark2))
- (when (eql object #\Newline)
- (setf object #\Space)))
- (when (>= (buffer-display-column buffer (offset mark2) tab-width)
- (1- fill-column))
- (fill-line mark2
- syntax-line-indentation-function
- fill-column
- tab-width
- compress-whitespaces
- syntax))))
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/developer-commands.lisp 2006/03/03 19:38:57 1.2
+++ /project/climacs/cvsroot/climacs/developer-commands.lisp 2006/07/24 13:24:40 1.3
@@ -26,7 +26,7 @@
;;; Commands for developing the Climacs editor.
-(in-package :climacs-gui)
+(in-package :climacs-commands)
(define-command (com-reset-profile :name t :command-table development-table) ()
#+sbcl (sb-profile:reset)
--- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/11 14:20:20 1.47
+++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/24 13:24:40 1.48
@@ -86,14 +86,16 @@
"pane"))
(:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane"
"window-commands" "gui"))
- (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands" "misc-commands" "window-commands" "file-commands"))
+ (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands"
+ "misc-commands" "window-commands" "file-commands" "core"))
#.(if (find-swank)
'(:file "lisp-syntax-swank" :depends-on ("lisp-syntax"))
(values))
(:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane"
"kill-ring" "io" "text-syntax"
"abbrev" "editing" "motion"))
- (:file "climacs" :depends-on ("gui"))
+ (:file "core" :depends-on ("gui"))
+ (:file "climacs" :depends-on ("gui" "core"))
;; (:file "buffer-commands" :depends-on ("gui"))
(:file "developer-commands" :depends-on ("gui" "lisp-syntax"))
(:file "motion-commands" :depends-on ("gui"))
@@ -111,7 +113,7 @@
:components
((:file "rt" :pathname #p"testing/rt.lisp")
(:file "buffer-test" :depends-on ("rt"))
- (:file "base-test" :depends-on ("rt"))
+ (:file "base-test" :depends-on ("rt" "buffer-test"))
(:module
"cl-automaton"
:depends-on ("rt")
--- /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/08 00:11:22 1.22
+++ /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/24 13:24:40 1.23
@@ -4,7 +4,8 @@
;;;
(cl:defpackage :climacs-tests
- (:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion :climacs-editing :automaton))
+ (:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion
+ :climacs-editing :automaton :climacs-core))
(cl:in-package :climacs-tests)
--- /project/climacs/cvsroot/climacs/base.lisp 2006/07/23 11:57:10 1.55
+++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 13:24:40 1.56
@@ -666,52 +666,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; 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 (buffer-whitespacep (object-after mark))
- do (delete-range mark 1))
- (loop until (beginning-of-buffer-p mark)
- while (buffer-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))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
;;; Kill ring
(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
More information about the Climacs-cvs
mailing list