Commit b136ff3b authored by Troels Henriksen's avatar Troels Henriksen

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.
parent 9cc12366
......@@ -664,52 +664,6 @@ delimited by mark1 and mark2."))
(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 (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
......
......@@ -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)
......
......@@ -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")
......
......@@ -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)
......
......@@ -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
......@@ -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)
......
......@@ -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 @@ Signals and error if the file does not exist."
'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
......
......@@ -72,7 +72,7 @@ string at point."
(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 @@ string at point."
(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 @@ string at point."
(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."))))
......
......@@ -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 @@ when deciding whether to prompt you to save the buffer before killing it."
'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 @@ The default fill column is 70."
'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 @@ Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane."
(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 @@ beginning of the buffer at leaves point there."
'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 @@ If there is no non-whitespace object, leaves point at the end of the line."
'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 @@ With a numeric argument, only delete whitespace before point."
'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 @@ FIXME: should distinguish between types of whitespace."
(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 @@ inserting each in turn at point as an expansion."
(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 @@ otherwise prints the result."
;; (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 #\( #\)))
......
......@@ -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)
......
......@@ -183,7 +183,9 @@ them all for changes after `body' has run)."
(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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
......
......@@ -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 @@ using the case of those objects if USE-REGION-CASE is true."
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 @@ using the case of those objects if USE-REGION-CASE is true."
(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 @@ using the case of those objects if USE-REGION-CASE is true."
(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)