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))