/[climacs]/climacs/gui.lisp
ViewVC logotype

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.102 - (hide annotations)
Sat Jan 29 06:53:44 2005 UTC (9 years, 2 months ago) by rstrandh
Branch: MAIN
Changes since 1.101: +8 -8 lines
The functions forward-word and backward-word now thake an
optional count argument.

The corresponding Climacs command now accept numeric arguments.
1 ejohnson 1.27 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2    
3 mvilleneuve 1.65 ;;; (c) copyright 2004-2005 by
4 ejohnson 1.27 ;;; Robert Strandh (strandh@labri.fr)
5 mvilleneuve 1.65 ;;; (c) copyright 2004-2005 by
6 ejohnson 1.27 ;;; Elliott Johnson (ejohnson@fasl.info)
7 mvilleneuve 1.65 ;;; (c) copyright 2005 by
8     ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 abakic 1.68 ;;; (c) copyright 2005 by
10     ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11 ejohnson 1.27
12     ;;; This library is free software; you can redistribute it and/or
13     ;;; modify it under the terms of the GNU Library General Public
14     ;;; License as published by the Free Software Foundation; either
15     ;;; version 2 of the License, or (at your option) any later version.
16     ;;;
17     ;;; This library is distributed in the hope that it will be useful,
18     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20     ;;; Library General Public License for more details.
21     ;;;
22     ;;; You should have received a copy of the GNU Library General Public
23     ;;; License along with this library; if not, write to the
24     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25     ;;; Boston, MA 02111-1307 USA.
26    
27     ;;; GUI for the Climacs editor.
28    
29     (in-package :climacs-gui)
30    
31 rstrandh 1.70 (defclass extended-pane (climacs-pane)
32     (;; allows a certain number of commands to have some minimal memory
33 rstrandh 1.49 (previous-command :initform nil :accessor previous-command)
34     ;; for next-line and previous-line commands
35     (goal-column :initform nil)
36     ;; for dynamic abbrev expansion
37     (original-prefix :initform nil)
38     (prefix-start-offset :initform nil)
39 abakic 1.68 (dabbrev-expansion-mark :initform nil)
40     (overwrite-mode :initform nil)))
41 ejohnson 1.27
42 rstrandh 1.81 (defclass info-pane (application-pane)
43     ((climacs-pane :initarg :climacs-pane)))
44    
45 rstrandh 1.28 (defclass minibuffer-pane (application-pane) ())
46    
47     (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
48     (declare (ignore type args))
49     (window-clear pane))
50    
51 ejohnson 1.27 (define-application-frame climacs ()
52 rstrandh 1.83 ((windows :accessor windows)
53 rstrandh 1.85 (buffers :initform '() :accessor buffers)
54     (recordingp :initform nil :accessor recordingp)
55     (executingp :initform nil :accessor executingp)
56     (recorded-keys :initform '() :accessor recorded-keys)
57     (remaining-keys :initform '() :accessor remaining-keys))
58 ejohnson 1.27 (:panes
59 rstrandh 1.81 (win (let* ((extended-pane
60     (make-pane 'extended-pane
61     :width 900 :height 400
62     :name 'bla
63     :incremental-redisplay t
64     :display-function 'display-win))
65     (info-pane
66     (make-pane 'info-pane
67     :climacs-pane extended-pane
68     :width 900 :height 20 :max-height 20 :min-height 20
69     ::background +gray85+
70     :scroll-bars nil
71     :borders nil
72     :incremental-redisplay t
73     :display-function 'display-info)))
74     (vertically ()
75     (scrolling ()
76     extended-pane)
77     info-pane)))
78 rstrandh 1.62 (int (make-pane 'minibuffer-pane
79     :width 900 :height 20 :max-height 20 :min-height 20
80     :scroll-bars nil)))
81 ejohnson 1.27 (:layouts
82     (default
83     (vertically (:scroll-bars nil)
84 rstrandh 1.77 win
85 rstrandh 1.80 int)))
86 ejohnson 1.27 (:top-level (climacs-top-level)))
87    
88 abakic 1.87 (defmacro current-window () ; shouldn't this be an inlined function? --amb
89 rstrandh 1.83 `(car (windows *application-frame*)))
90 rstrandh 1.80
91 rstrandh 1.98 (defmethod execute-frame-command :around ((frame climacs) command)
92     (declare (ignore command))
93     (with-undo ((buffer (current-window)))
94     (call-next-method)))
95    
96 rstrandh 1.80 (defmethod redisplay-frame-panes :around ((frame climacs) &rest args)
97 rstrandh 1.70 (declare (ignore args))
98 rstrandh 1.83 (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame)))))
99     (loop for buffer in buffers
100     do (update-syntax buffer (syntax buffer)))
101 rstrandh 1.80 (call-next-method)
102 rstrandh 1.83 (loop for buffer in buffers
103     do (clear-modify buffer))))
104 rstrandh 1.28
105 ejohnson 1.27 (defun climacs ()
106     "Starts up a climacs session"
107     (let ((frame (make-application-frame 'climacs)))
108     (run-frame-top-level frame)))
109    
110 rstrandh 1.30 (defun display-message (format-string &rest format-args)
111     (apply #'format *standard-input* format-string format-args))
112    
113 ejohnson 1.27 (defun display-info (frame pane)
114 rstrandh 1.81 (declare (ignore frame))
115     (with-slots (climacs-pane) pane
116     (let* ((buf (buffer climacs-pane))
117 mvilleneuve 1.96 (name-info (format nil " ~a ~a Syntax: ~a~a~a~a ~a"
118 rstrandh 1.81 (if (needs-saving buf) "**" "--")
119     (name buf)
120     (name (syntax buf))
121     (if (slot-value climacs-pane 'overwrite-mode)
122 mvilleneuve 1.86 " Ovwrt"
123 rstrandh 1.85 "")
124 mvilleneuve 1.92 (if (auto-fill-mode climacs-pane)
125 mvilleneuve 1.86 " Fill"
126     "")
127 mvilleneuve 1.96 (if (isearch-mode climacs-pane)
128     " Isearch"
129     "")
130 rstrandh 1.85 (if (recordingp *application-frame*)
131     "Def"
132 rstrandh 1.81 ""))))
133     (princ name-info pane))))
134 ejohnson 1.27
135     (defun display-win (frame pane)
136     "The display function used by the climacs application frame."
137     (declare (ignore frame))
138 rstrandh 1.83 (redisplay-pane pane (eq pane (car (windows *application-frame*)))))
139 ejohnson 1.27
140     (defun find-gestures (gestures start-table)
141     (loop with table = (find-command-table start-table)
142     for (gesture . rest) on gestures
143     for item = (find-keystroke-item gesture table :errorp nil)
144     while item
145     do (if (eq (command-menu-item-type item) :command)
146     (return (if (null rest) item nil))
147     (setf table (command-menu-item-value item)))
148     finally (return item)))
149    
150 ejohnson 1.50 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
151 ejohnson 1.27 (defparameter *current-gesture* nil)
152    
153 rstrandh 1.36 (defun meta-digit (gesture)
154     (position gesture
155     '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)
156     (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
157     :test #'event-matches-gesture-name-p))
158    
159 rstrandh 1.47 (defun climacs-read-gesture ()
160 rstrandh 1.85 (unless (null (remaining-keys *application-frame*))
161     (return-from climacs-read-gesture
162     (pop (remaining-keys *application-frame*))))
163 rstrandh 1.47 (loop for gesture = (read-gesture :stream *standard-input*)
164 rstrandh 1.85 when (event-matches-gesture-name-p gesture '(:keyboard #\g 512)) ; FIXME
165 rstrandh 1.47 do (throw 'outer-loop nil)
166     until (or (characterp gesture)
167     (and (typep gesture 'keyboard-event)
168     (or (keyboard-event-character gesture)
169     (not (member (keyboard-event-key-name
170     gesture)
171     '(:control-left :control-right
172     :shift-left :shift-right
173     :meta-left :meta-right
174     :super-left :super-right
175     :hyper-left :hyper-right
176     :shift-lock :caps-lock
177     :alt-left :alt-right))))))
178 rstrandh 1.85 finally (progn (when (recordingp *application-frame*)
179     (push gesture (recorded-keys *application-frame*)))
180     (return gesture))))
181    
182     (defun climacs-unread-gesture (gesture stream)
183     (cond ((recordingp *application-frame*)
184 rstrandh 1.88 (pop (recorded-keys *application-frame*))
185     (unread-gesture gesture :stream stream))
186 rstrandh 1.85 ((executingp *application-frame*)
187 rstrandh 1.88 (push gesture (remaining-keys *application-frame*)))
188     (t
189     (unread-gesture gesture :stream stream))))
190 rstrandh 1.47
191 rstrandh 1.36 (defun read-numeric-argument (&key (stream *standard-input*))
192 rstrandh 1.47 (let ((gesture (climacs-read-gesture)))
193 rstrandh 1.62 (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
194 rstrandh 1.36 (let ((numarg 4))
195 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
196 rstrandh 1.62 while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
197 rstrandh 1.36 do (setf numarg (* 4 numarg))
198 rstrandh 1.85 finally (climacs-unread-gesture gesture stream))
199 rstrandh 1.47 (let ((gesture (climacs-read-gesture)))
200 rstrandh 1.36 (cond ((and (characterp gesture)
201     (digit-char-p gesture 10))
202     (setf numarg (- (char-code gesture) (char-code #\0)))
203 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
204 rstrandh 1.36 while (and (characterp gesture)
205     (digit-char-p gesture 10))
206 rstrandh 1.62 do (setf numarg (+ (* 10 numarg)
207     (- (char-code gesture) (char-code #\0))))
208 rstrandh 1.85 finally (climacs-unread-gesture gesture stream)
209 rstrandh 1.36 (return (values numarg t))))
210     (t
211 rstrandh 1.85 (climacs-unread-gesture gesture stream)
212 rstrandh 1.36 (values numarg t))))))
213     ((meta-digit gesture)
214     (let ((numarg (meta-digit gesture)))
215 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
216 rstrandh 1.36 while (meta-digit gesture)
217     do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
218 rstrandh 1.85 finally (climacs-unread-gesture gesture stream)
219 rstrandh 1.36 (return (values numarg t)))))
220 rstrandh 1.85 (t (climacs-unread-gesture gesture stream)
221 rstrandh 1.36 (values 1 nil)))))
222    
223 rstrandh 1.77 ;;; we know the vbox pane has a scroller pane and an info
224     ;;; pane in it. The scroller pane has a viewport in it,
225     ;;; and the viewport contains the climacs-pane as its only child.
226     (defun find-climacs-pane (vbox)
227     (first (sheet-children
228     (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane))
229     (sheet-children
230     (find-if (lambda (pane) (typep pane 'scroller-pane))
231     (sheet-children vbox)))))))
232    
233 ejohnson 1.27 (defun climacs-top-level (frame &key
234     command-parser command-unparser
235     partial-command-parser prompt)
236     (declare (ignore command-parser command-unparser partial-command-parser prompt))
237 rstrandh 1.83 (with-slots (windows) frame
238     (setf windows (list (find-climacs-pane (find-pane-named frame 'win))))
239     (push (buffer (car windows)) (buffers frame))
240     (let ((*standard-output* (car windows))
241 rstrandh 1.77 (*standard-input* (find-pane-named frame 'int))
242     (*print-pretty* nil)
243     (*abort-gestures* nil))
244     (redisplay-frame-panes frame :force-p t)
245     (loop (catch 'outer-loop
246     (loop for gestures = '()
247     for numarg = (read-numeric-argument :stream *standard-input*)
248     do (loop (setf *current-gesture* (climacs-read-gesture))
249     (setf gestures (nconc gestures (list *current-gesture*)))
250     (let ((item (find-gestures gestures 'global-climacs-table)))
251     (cond ((not item)
252     (beep) (return))
253     ((eq (command-menu-item-type item) :command)
254     (let ((command (command-menu-item-value item)))
255     (unless (consp command)
256     (setf command (list command)))
257     (setf command (substitute-numeric-argument-marker command numarg))
258     (handler-case
259     (execute-frame-command frame command)
260     (error (condition)
261     (beep)
262     (format *error-output* "~a~%" condition)))
263     (setf (previous-command *standard-output*)
264     (if (consp command)
265     (car command)
266     command))
267     (return)))
268     (t nil))))
269 rstrandh 1.83 (let ((buffer (buffer (current-window))))
270 rstrandh 1.77 (when (modified-p buffer)
271     (setf (needs-saving buffer) t)))
272 rstrandh 1.85 (when (null (remaining-keys *application-frame*))
273     (setf (executingp *application-frame*) nil)
274     (redisplay-frame-panes frame))))
275 rstrandh 1.77 (beep)
276 rstrandh 1.83 (let ((buffer (buffer (current-window))))
277 rstrandh 1.77 (when (modified-p buffer)
278     (setf (needs-saving buffer) t)))
279 rstrandh 1.85 (when (null (remaining-keys *application-frame*))
280     (setf (executingp *application-frame*) nil)
281     (redisplay-frame-panes frame))))))
282 ejohnson 1.27
283 mvilleneuve 1.100 (defmacro simple-command-loop (command-table loop-condition end-clauses)
284     (let ((gesture (gensym))
285     (item (gensym))
286     (command (gensym))
287     (condition (gensym)))
288     `(progn
289     (redisplay-frame-panes *application-frame*)
290     (loop while ,loop-condition
291     as ,gesture = (climacs-read-gesture)
292     as ,item = (find-gestures (list ,gesture) ,command-table)
293     do (cond ((and ,item (eq (command-menu-item-type ,item) :command))
294     (setf *current-gesture* ,gesture)
295     (let ((,command (command-menu-item-value ,item)))
296     (unless (consp ,command)
297     (setf ,command (list ,command)))
298     (handler-case
299     (execute-frame-command *application-frame*
300     ,command)
301     (error (,condition)
302     (beep)
303     (format *error-output* "~a~%" ,condition)))))
304     (t
305     (unread-gesture ,gesture)
306     ,@end-clauses))
307     (redisplay-frame-panes *application-frame*)))))
308    
309 mvilleneuve 1.64 (defun region-limits (pane)
310 rstrandh 1.70 (if (mark< (mark pane) (point pane))
311     (values (mark pane) (point pane))
312     (values (point pane) (mark pane))))
313 mvilleneuve 1.64
314 abridgewater 1.34 (defmacro define-named-command (command-name args &body body)
315 rstrandh 1.62 `(define-climacs-command ,(if (listp command-name)
316     `(,@command-name :name t)
317     `(,command-name :name t)) ,args ,@body))
318 abridgewater 1.34
319 abakic 1.58 (define-named-command com-toggle-overwrite-mode ()
320 abakic 1.87 (with-slots (overwrite-mode) (current-window)
321     (setf overwrite-mode (not overwrite-mode))))
322 abakic 1.58
323 mvilleneuve 1.89 (defun possibly-fill-line ()
324 mvilleneuve 1.86 (let* ((pane (current-window))
325     (buffer (buffer pane)))
326 mvilleneuve 1.92 (when (auto-fill-mode pane)
327 mvilleneuve 1.95 (let* ((fill-column (auto-fill-column pane))
328 mvilleneuve 1.86 (point (point pane))
329     (offset (offset point))
330     (tab-width (tab-space-count (stream-default-view pane)))
331     (syntax (syntax buffer)))
332     (when (>= (buffer-display-column buffer offset tab-width)
333 mvilleneuve 1.95 (1- fill-column))
334 mvilleneuve 1.86 (fill-line point
335     (lambda (mark)
336     (syntax-line-indentation mark tab-width syntax))
337     fill-column
338 mvilleneuve 1.89 tab-width))))))
339    
340     (defun insert-character (char)
341     (let* ((win (current-window))
342     (point (point win)))
343     (unless (constituentp char)
344     (possibly-expand-abbrev point))
345     (when (whitespacep char)
346     (possibly-fill-line))
347     (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point)))
348     (progn
349     (delete-range point)
350     (insert-object point char))
351     (insert-object point char))))
352    
353     (define-command com-self-insert ()
354 mvilleneuve 1.86 (insert-character *current-gesture*))
355 ejohnson 1.27
356 abridgewater 1.34 (define-named-command com-beginning-of-line ()
357 rstrandh 1.80 (beginning-of-line (point (current-window))))
358 ejohnson 1.27
359 abridgewater 1.34 (define-named-command com-end-of-line ()
360 rstrandh 1.80 (end-of-line (point (current-window))))
361 ejohnson 1.27
362 rstrandh 1.62 (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
363 rstrandh 1.80 (delete-range (point (current-window)) count))
364 ejohnson 1.27
365 rstrandh 1.62 (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
366 rstrandh 1.80 (delete-range (point (current-window)) (- count)))
367 ejohnson 1.27
368 rstrandh 1.42 (define-named-command com-transpose-objects ()
369 rstrandh 1.80 (let* ((point (point (current-window))))
370 rstrandh 1.42 (unless (beginning-of-buffer-p point)
371     (when (end-of-line-p point)
372 rstrandh 1.43 (backward-object point))
373     (let ((object (object-after point)))
374     (delete-range point)
375     (backward-object point)
376     (insert-object point object)
377     (forward-object point)))))
378    
379 rstrandh 1.62 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
380 rstrandh 1.80 (backward-object (point (current-window)) count))
381 rstrandh 1.43
382 rstrandh 1.62 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
383 rstrandh 1.80 (forward-object (point (current-window)) count))
384 rstrandh 1.43
385     (define-named-command com-transpose-words ()
386 rstrandh 1.80 (let* ((point (point (current-window))))
387 rstrandh 1.43 (let (bw1 bw2 ew1 ew2)
388     (backward-word point)
389     (setf bw1 (offset point))
390     (forward-word point)
391     (setf ew1 (offset point))
392     (forward-word point)
393     (when (= (offset point) ew1)
394     ;; this is emacs' message in the minibuffer
395     (error "Don't have two things to transpose"))
396     (setf ew2 (offset point))
397     (backward-word point)
398     (setf bw2 (offset point))
399     (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
400     (w1 (buffer-sequence (buffer point) bw1 ew1)))
401     (delete-word point)
402     (insert-sequence point w1)
403     (backward-word point)
404     (backward-word point)
405     (delete-word point)
406     (insert-sequence point w2)
407     (forward-word point)))))
408 rstrandh 1.42
409 rstrandh 1.45 (define-named-command com-transpose-lines ()
410 rstrandh 1.80 (let ((point (point (current-window))))
411 rstrandh 1.45 (beginning-of-line point)
412     (unless (beginning-of-buffer-p point)
413     (previous-line point))
414     (let* ((bol (offset point))
415     (eol (progn (end-of-line point)
416     (offset point)))
417     (line (buffer-sequence (buffer point) bol eol)))
418     (delete-region bol point)
419     ;; Remove newline at end of line as well.
420     (unless (end-of-buffer-p point)
421     (delete-range point))
422     ;; If the current line is at the end of the buffer, we want to
423     ;; be able to insert past it, so we need to get an extra line
424     ;; at the end.
425 abakic 1.82 (end-of-line point)
426     (when (end-of-buffer-p point)
427 rstrandh 1.45 (insert-object point #\Newline))
428 abakic 1.82 (next-line point 0)
429 rstrandh 1.45 (insert-sequence point line)
430     (insert-object point #\Newline))))
431    
432 abridgewater 1.34 (define-named-command com-previous-line ()
433 rstrandh 1.80 (let* ((win (current-window))
434 rstrandh 1.49 (point (point win)))
435     (unless (or (eq (previous-command win) 'com-previous-line)
436     (eq (previous-command win) 'com-next-line))
437     (setf (slot-value win 'goal-column) (column-number point)))
438     (previous-line point (slot-value win 'goal-column))))
439 ejohnson 1.27
440 abridgewater 1.34 (define-named-command com-next-line ()
441 rstrandh 1.80 (let* ((win (current-window))
442 rstrandh 1.49 (point (point win)))
443     (unless (or (eq (previous-command win) 'com-previous-line)
444     (eq (previous-command win) 'com-next-line))
445     (setf (slot-value win 'goal-column) (column-number point)))
446     (next-line point (slot-value win 'goal-column))))
447 ejohnson 1.27
448 abridgewater 1.34 (define-named-command com-open-line ()
449 rstrandh 1.80 (open-line (point (current-window))))
450 ejohnson 1.27
451 abridgewater 1.34 (define-named-command com-kill-line ()
452 rstrandh 1.80 (let* ((pane (current-window))
453 ejohnson 1.54 (point (point pane))
454     (mark (offset point)))
455 ejohnson 1.56 (cond ((end-of-buffer-p point) nil)
456     ((end-of-line-p point)(forward-object point))
457     (t
458     (end-of-line point)
459     (cond ((beginning-of-buffer-p point) nil)
460     ((beginning-of-line-p point)(forward-object point)))))
461 ejohnson 1.54 (if (eq (previous-command pane) 'com-kill-line)
462 ejohnson 1.51 (kill-ring-concatenating-push *kill-ring*
463 ejohnson 1.54 (region-to-sequence mark point))
464 ejohnson 1.51 (kill-ring-standard-push *kill-ring*
465 ejohnson 1.54 (region-to-sequence mark point)))
466     (delete-region mark point)))
467 ejohnson 1.27
468 rstrandh 1.102 (define-named-command com-forward-word ((count 'integer :prompt "Number of words"))
469     (forward-word (point (current-window)) count))
470 ejohnson 1.27
471 rstrandh 1.102 (define-named-command com-backward-word ((count 'integer :prompt "Number of words"))
472     (backward-word (point (current-window)) count))
473 ejohnson 1.27
474 abridgewater 1.34 (define-named-command com-delete-word ()
475 rstrandh 1.80 (delete-word (point (current-window))))
476 rstrandh 1.32
477 abridgewater 1.34 (define-named-command com-backward-delete-word ()
478 rstrandh 1.80 (backward-delete-word (point (current-window))))
479 rstrandh 1.32
480 mvilleneuve 1.64 (define-named-command com-upcase-region ()
481 abakic 1.101 (let ((cw (current-window)))
482     (upcase-region (mark cw) (point cw))))
483 mvilleneuve 1.64
484     (define-named-command com-downcase-region ()
485 abakic 1.101 (let ((cw (current-window)))
486     (downcase-region (mark cw) (point cw))))
487 mvilleneuve 1.64
488     (define-named-command com-capitalize-region ()
489 abakic 1.101 (let ((cw (current-window)))
490     (capitalize-region (mark cw) (point cw))))
491 mvilleneuve 1.64
492 rstrandh 1.60 (define-named-command com-upcase-word ()
493 rstrandh 1.80 (upcase-word (point (current-window))))
494 rstrandh 1.60
495     (define-named-command com-downcase-word ()
496 rstrandh 1.80 (downcase-word (point (current-window))))
497 rstrandh 1.60
498     (define-named-command com-capitalize-word ()
499 rstrandh 1.80 (capitalize-word (point (current-window))))
500 rstrandh 1.60
501 mvilleneuve 1.69 (define-named-command com-tabify-region ()
502 rstrandh 1.80 (let ((pane (current-window)))
503 mvilleneuve 1.69 (multiple-value-bind (start end) (region-limits pane)
504 rstrandh 1.70 (tabify-region start end (tab-space-count (stream-default-view pane))))))
505 mvilleneuve 1.69
506     (define-named-command com-untabify-region ()
507 rstrandh 1.80 (let ((pane (current-window)))
508 mvilleneuve 1.69 (multiple-value-bind (start end) (region-limits pane)
509 rstrandh 1.70 (untabify-region start end (tab-space-count (stream-default-view pane))))))
510 mvilleneuve 1.69
511 mvilleneuve 1.79 (defun indent-current-line (pane point)
512     (let* ((buffer (buffer pane))
513     (view (stream-default-view pane))
514     (tab-space-count (tab-space-count view))
515     (indentation (syntax-line-indentation point
516     tab-space-count
517     (syntax buffer))))
518     (indent-line point indentation (and (indent-tabs-mode buffer)
519     tab-space-count))))
520    
521     (define-named-command com-indent-line ()
522 rstrandh 1.80 (let* ((pane (current-window))
523 mvilleneuve 1.79 (point (point pane)))
524     (indent-current-line pane point)))
525    
526     (define-named-command com-newline-and-indent ()
527 rstrandh 1.80 (let* ((pane (current-window))
528 mvilleneuve 1.79 (point (point pane)))
529     (insert-object point #\Newline)
530     (indent-current-line pane point)))
531    
532 mvilleneuve 1.72 (define-named-command com-delete-indentation ()
533 rstrandh 1.80 (delete-indentation (point (current-window))))
534 ejohnson 1.27
535 mvilleneuve 1.86 (define-named-command com-auto-fill-mode ()
536 mvilleneuve 1.92 (let ((pane (current-window)))
537     (setf (auto-fill-mode pane) (not (auto-fill-mode pane)))))
538 mvilleneuve 1.86
539 mvilleneuve 1.90 (define-named-command com-fill-paragraph ()
540     (let* ((pane (current-window))
541     (buffer (buffer pane))
542     (syntax (syntax buffer))
543     (point (point pane))
544     (begin-mark (clone-mark point))
545     (end-mark (clone-mark point)))
546     (unless (eql (object-before begin-mark) #\Newline)
547     (beginning-of-paragraph begin-mark syntax))
548     (unless (eql (object-after end-mark) #\Newline)
549     (end-of-paragraph end-mark syntax))
550     (do-buffer-region (object offset buffer
551     (offset begin-mark) (offset end-mark))
552     (when (eql object #\Newline)
553     (setf object #\Space)))
554     (let ((point-backup (clone-mark point)))
555     (setf (offset point) (offset end-mark))
556     (possibly-fill-line)
557     (setf (offset point) (offset point-backup)))))
558    
559 ejohnson 1.27 (define-command com-extended-command ()
560     (let ((item (accept 'command :prompt "Extended Command")))
561     (execute-frame-command *application-frame* item)))
562    
563 rstrandh 1.41 (eval-when (:compile-toplevel :load-toplevel)
564 ejohnson 1.35 (define-presentation-type completable-pathname ()
565     :inherit-from 'pathname))
566 ejohnson 1.27
567     (defun filename-completer (so-far mode)
568     (flet ((remove-trail (s)
569     (subseq s 0 (let ((pos (position #\/ s :from-end t)))
570     (if pos (1+ pos) 0)))))
571     (let* ((directory-prefix
572     (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
573     ""
574 rstrandh 1.78 (namestring #+sbcl *default-pathname-defaults*
575     #+cmu (ext:default-directory)
576     #-(or sbcl cmu) *default-pathname-defaults*)))
577 ejohnson 1.27 (full-so-far (concatenate 'string directory-prefix so-far))
578     (pathnames
579     (loop with length = (length full-so-far)
580     for path in (directory (concatenate 'string
581     (remove-trail so-far)
582     "*.*"))
583     when (let ((mismatch (mismatch (namestring path) full-so-far)))
584     (or (null mismatch) (= mismatch length)))
585     collect path))
586     (strings (mapcar #'namestring pathnames))
587     (first-string (car strings))
588     (length-common-prefix nil)
589     (completed-string nil)
590     (full-completed-string nil))
591     (unless (null pathnames)
592     (setf length-common-prefix
593     (loop with length = (length first-string)
594     for string in (cdr strings)
595     do (setf length (min length (or (mismatch string first-string) length)))
596     finally (return length))))
597     (unless (null pathnames)
598     (setf completed-string
599     (subseq first-string (length directory-prefix)
600     (if (null (cdr pathnames)) nil length-common-prefix)))
601     (setf full-completed-string
602     (concatenate 'string directory-prefix completed-string)))
603     (case mode
604     ((:complete-limited :complete-maximal)
605     (cond ((null pathnames)
606     (values so-far nil nil 0 nil))
607     ((null (cdr pathnames))
608     (values completed-string t (car pathnames) 1 nil))
609     (t
610     (values completed-string nil nil (length pathnames) nil))))
611     (:complete
612     (cond ((null pathnames)
613     (values so-far t so-far 1 nil))
614     ((null (cdr pathnames))
615     (values completed-string t (car pathnames) 1 nil))
616     ((find full-completed-string strings :test #'string-equal)
617     (let ((pos (position full-completed-string strings :test #'string-equal)))
618     (values completed-string
619     t (elt pathnames pos) (length pathnames) nil)))
620     (t
621     (values completed-string nil nil (length pathnames) nil))))
622     (:possibilities
623     (values nil nil nil (length pathnames)
624     (loop with length = (length directory-prefix)
625     for name in pathnames
626     collect (list (subseq (namestring name) length nil)
627     name))))))))
628    
629     (define-presentation-method accept
630     ((type completable-pathname) stream (view textual-view) &key)
631     (multiple-value-bind (pathname success string)
632     (complete-input stream
633     #'filename-completer
634     :partial-completers '(#\Space)
635     :allow-any-input t)
636     (declare (ignore success))
637     (or pathname string)))
638    
639     (defun pathname-filename (pathname)
640     (if (null (pathname-type pathname))
641     (pathname-name pathname)
642     (concatenate 'string (pathname-name pathname)
643     "." (pathname-type pathname))))
644    
645 abridgewater 1.34 (define-named-command com-find-file ()
646 ejohnson 1.27 (let ((filename (accept 'completable-pathname
647 rstrandh 1.70 :prompt "Find File"))
648     (buffer (make-instance 'climacs-buffer))
649 rstrandh 1.80 (pane (current-window)))
650 rstrandh 1.75 (push buffer (buffers *application-frame*))
651 rstrandh 1.80 (setf (buffer (current-window)) buffer)
652 rstrandh 1.70 (setf (syntax buffer) (make-instance 'basic-syntax))
653 rstrandh 1.84 ;; Don't want to create the file if it doesn't exist.
654     (when (probe-file filename)
655     (with-open-file (stream filename :direction :input)
656     (input-from-stream stream buffer 0)))
657 rstrandh 1.70 (setf (filename buffer) filename
658     (name buffer) (pathname-filename filename)
659     (needs-saving buffer) nil)
660     (beginning-of-buffer (point pane))
661     ;; this one is needed so that the buffer modification protocol
662     ;; resets the low and high marks after redisplay
663     (redisplay-frame-panes *application-frame*)))
664 ejohnson 1.27
665 rstrandh 1.93 (defun save-buffer (buffer)
666     (let ((filename (or (filename buffer)
667     (accept 'completable-pathname
668     :prompt "Save Buffer to File"))))
669     (with-open-file (stream filename :direction :output :if-exists :supersede)
670     (output-to-stream stream buffer 0 (size buffer)))
671     (setf (filename buffer) filename
672     (name buffer) (pathname-filename filename))
673     (display-message "Wrote: ~a" (filename buffer))
674     (setf (needs-saving buffer) nil)))
675    
676 abridgewater 1.34 (define-named-command com-save-buffer ()
677 rstrandh 1.93 (let ((buffer (buffer (current-window))))
678 rstrandh 1.30 (if (or (null (filename buffer))
679     (needs-saving buffer))
680 rstrandh 1.93 (save-buffer buffer)
681     (display-message "No changes need to be saved from ~a" (name buffer)))))
682    
683     (define-named-command (com-quit) ()
684     (loop for buffer in (buffers *application-frame*)
685     when (and (needs-saving buffer)
686     (accept 'boolean
687     :prompt (format nil "Save buffer: ~a ?" (name buffer))))
688     do (save-buffer buffer))
689     (when (or (notany #'needs-saving
690     (buffers *application-frame*))
691     (accept 'boolean :prompt "Modified buffers exist. Quit anyway?"))
692     (frame-exit *application-frame*)))
693 ejohnson 1.27
694 abridgewater 1.34 (define-named-command com-write-buffer ()
695 ejohnson 1.27 (let ((filename (accept 'completable-pathname
696     :prompt "Write Buffer to File"))
697 rstrandh 1.80 (buffer (buffer (current-window))))
698 ejohnson 1.27 (with-open-file (stream filename :direction :output :if-exists :supersede)
699     (output-to-stream stream buffer 0 (size buffer)))
700     (setf (filename buffer) filename
701 rstrandh 1.28 (name buffer) (pathname-filename filename)
702 rstrandh 1.30 (needs-saving buffer) nil)
703     (display-message "Wrote: ~a" (filename buffer))))
704 ejohnson 1.27
705 rstrandh 1.75 (define-presentation-method accept
706     ((type buffer) stream (view textual-view) &key)
707     (multiple-value-bind (object success string)
708     (complete-input stream
709     (lambda (so-far action)
710     (complete-from-possibilities
711     so-far (buffers *application-frame*) '() :action action
712     :name-key #'name
713     :value-key #'identity))
714     :partial-completers '(#\Space)
715     :allow-any-input t)
716 rstrandh 1.76 (declare (ignore success))
717     (or object
718     (car (push (make-instance 'climacs-buffer :name string)
719     (buffers *application-frame*))))))
720 rstrandh 1.75
721     (define-named-command com-switch-to-buffer ()
722     (let ((buffer (accept 'buffer
723     :prompt "Switch to buffer")))
724 rstrandh 1.80 (setf (buffer (current-window)) buffer)
725 rstrandh 1.75 (setf (syntax buffer) (make-instance 'basic-syntax))
726 rstrandh 1.80 (beginning-of-buffer (point (current-window)))
727     (full-redisplay (current-window))))
728 rstrandh 1.75
729 rstrandh 1.91 (define-named-command com-kill-buffer ()
730     (with-slots (buffers) *application-frame*
731     (let ((buffer (buffer (current-window))))
732     (when (and (needs-saving buffer)
733     (accept 'boolean :prompt "Save buffer first?"))
734     (com-save-buffer))
735     (setf buffers (remove buffer buffers))
736     ;; Always need one buffer.
737     (when (null buffers)
738     (push (make-instance 'climacs-buffer :name "*scratch*")
739     buffers))
740     (setf (buffer (current-window)) (car buffers)))))
741    
742 rstrandh 1.75 (define-named-command com-full-redisplay ()
743 rstrandh 1.80 (full-redisplay (current-window)))
744 rstrandh 1.75
745 rstrandh 1.63 (define-named-command com-load-file ()
746     (let ((filename (accept 'completable-pathname
747     :prompt "Load File")))
748     (load filename)))
749    
750 abridgewater 1.34 (define-named-command com-beginning-of-buffer ()
751 rstrandh 1.80 (beginning-of-buffer (point (current-window))))
752 ejohnson 1.27
753 rstrandh 1.39 (define-named-command com-page-down ()
754 rstrandh 1.80 (let ((pane (current-window)))
755 rstrandh 1.70 (page-down pane)))
756 rstrandh 1.39
757 rstrandh 1.40 (define-named-command com-page-up ()
758 rstrandh 1.80 (let ((pane (current-window)))
759 rstrandh 1.70 (page-up pane)))
760 rstrandh 1.40
761 abridgewater 1.34 (define-named-command com-end-of-buffer ()
762 rstrandh 1.80 (end-of-buffer (point (current-window))))
763 ejohnson 1.27
764 abridgewater 1.34 (define-named-command com-back-to-indentation ()
765 rstrandh 1.80 (let ((point (point (current-window))))
766 rstrandh 1.32 (beginning-of-line point)
767     (loop until (end-of-line-p point)
768     while (whitespacep (object-after point))
769     do (incf (offset point)))))
770    
771 abridgewater 1.34 (define-named-command com-goto-position ()
772 rstrandh 1.80 (setf (offset (point (current-window)))
773 rstrandh 1.32 (accept 'integer :prompt "Goto Position")))
774    
775 abridgewater 1.34 (define-named-command com-goto-line ()
776 abakic 1.99 (loop with mark = (make-instance 'standard-right-sticky-mark ;PB
777 rstrandh 1.80 :buffer (buffer (current-window)))
778 rstrandh 1.32 do (end-of-line mark)
779     until (end-of-buffer-p mark)
780     repeat (accept 'integer :prompt "Goto Line")
781     do (incf (offset mark))
782     (end-of-line mark)
783     finally (beginning-of-line mark)
784 rstrandh 1.80 (setf (offset (point (current-window)))
785 rstrandh 1.32 (offset mark))))
786    
787 abridgewater 1.34 (define-named-command com-browse-url ()
788 ejohnson 1.27 (accept 'url :prompt "Browse URL"))
789    
790 abridgewater 1.34 (define-named-command com-set-mark ()
791 rstrandh 1.80 (let ((pane (current-window)))
792 rstrandh 1.70 (setf (mark pane) (clone-mark (point pane)))))
793 rstrandh 1.45
794     (define-named-command com-exchange-point-and-mark ()
795 rstrandh 1.80 (let ((pane (current-window)))
796 rstrandh 1.70 (psetf (offset (mark pane)) (offset (point pane))
797     (offset (point pane)) (offset (mark pane)))))
798 rstrandh 1.38
799     (define-named-command com-set-syntax ()
800 rstrandh 1.80 (let* ((pane (current-window))
801 rstrandh 1.67 (buffer (buffer pane)))
802 rstrandh 1.70 (setf (syntax buffer)
803     (make-instance (accept 'syntax :prompt "Set Syntax")))
804 rstrandh 1.67 (setf (offset (low-mark buffer)) 0
805     (offset (high-mark buffer)) (size buffer))))
806 ejohnson 1.27
807 rstrandh 1.77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
808     ;;;
809 rstrandh 1.85 ;;; Keyboard macros
810    
811     (define-named-command com-start-kbd-macro ()
812     (setf (recordingp *application-frame*) t)
813     (setf (recorded-keys *application-frame*) '()))
814    
815     (define-named-command com-end-kbd-macro ()
816     (setf (recordingp *application-frame*) nil)
817     (setf (recorded-keys *application-frame*)
818     ;; this won't work if the command was invoked in any old way
819     (reverse (cddr (recorded-keys *application-frame*)))))
820    
821     (define-named-command com-call-last-kbd-macro ()
822     (setf (remaining-keys *application-frame*)
823     (recorded-keys *application-frame*))
824     (setf (executingp *application-frame*) t))
825    
826     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
827     ;;;
828 rstrandh 1.77 ;;; Commands for splitting windows
829    
830 rstrandh 1.91 ;;; put this in for real when we find a solution for the problem
831     ;;; it causes for com-delete-window
832     ;; (defun replace-constellation (constellation additional-constellation vertical-p)
833     ;; (let* ((parent (sheet-parent constellation))
834     ;; (children (sheet-children parent))
835     ;; (first (first children))
836     ;; (second (second children))
837     ;; (adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
838     ;; (assert (member constellation children))
839     ;; (cond ((eq constellation first)
840     ;; (sheet-disown-child parent constellation)
841     ;; (let ((new (if vertical-p
842     ;; (vertically ()
843     ;; constellation adjust additional-constellation)
844     ;; (horizontally ()
845     ;; constellation adjust additional-constellation))))
846     ;; (sheet-adopt-child parent new)
847     ;; (reorder-sheets parent (list new second))))
848     ;; (t
849     ;; (sheet-disown-child parent constellation)
850     ;; (let ((new (if vertical-p
851     ;; (vertically ()
852     ;; constellation adjust additional-constellation)
853     ;; (horizontally ()
854     ;; constellation adjust additional-constellation))))
855     ;; (sheet-adopt-child parent new)
856     ;; (reorder-sheets parent (list first new)))))))
857    
858 rstrandh 1.83 (defun replace-constellation (constellation additional-constellation vertical-p)
859     (let* ((parent (sheet-parent constellation))
860     (children (sheet-children parent))
861     (first (first children))
862     (second (second children)))
863     (assert (member constellation children))
864     (cond ((eq constellation first)
865     (sheet-disown-child parent constellation)
866     (let ((new (if vertical-p
867     (vertically () constellation additional-constellation)
868     (horizontally () constellation additional-constellation))))
869     (sheet-adopt-child parent new)
870     (reorder-sheets parent (list new second))))
871     (t
872     (sheet-disown-child parent constellation)
873     (let ((new (if vertical-p
874     (vertically () constellation additional-constellation)
875     (horizontally () constellation additional-constellation))))
876     (sheet-adopt-child parent new)
877     (reorder-sheets parent (list first new)))))))
878    
879     (defun parent3 (sheet)
880     (sheet-parent (sheet-parent (sheet-parent sheet))))
881    
882     (defun make-pane-constellation ()
883     "make a vbox containing a scroller pane as its first child and an
884     info pane as its second child. The scroller pane contains a viewport
885     which contains an extended pane. Return the vbox and the extended pane
886     as two values"
887     (let* ((extended-pane
888     (make-pane 'extended-pane
889     :width 900 :height 400
890     :name 'win
891     :incremental-redisplay t
892     :display-function 'display-win))
893     (vbox
894     (vertically ()
895     (scrolling () extended-pane)
896     (make-pane 'info-pane
897     :climacs-pane extended-pane
898     :width 900 :height 20
899     :max-height 20 :min-height 20
900     ::background +gray85+
901     :scroll-bars nil
902     :borders nil
903     :incremental-redisplay t
904     :display-function 'display-info))))
905     (values vbox extended-pane)))
906    
907 rstrandh 1.77 (define-named-command com-split-window-vertically ()
908     (with-look-and-feel-realization
909     ((frame-manager *application-frame*) *application-frame*)
910 rstrandh 1.83 (multiple-value-bind (vbox new-pane) (make-pane-constellation)
911     (let* ((current-window (current-window))
912     (constellation-root (parent3 current-window)))
913 mvilleneuve 1.95 (setf (buffer new-pane) (buffer current-window)
914     (auto-fill-mode new-pane) (auto-fill-mode current-window)
915     (auto-fill-column new-pane) (auto-fill-column current-window))
916 rstrandh 1.83 (push new-pane (windows *application-frame*))
917     (replace-constellation constellation-root vbox t)
918     (full-redisplay current-window)
919     (full-redisplay new-pane)))))
920    
921     (define-named-command com-split-window-horizontally ()
922     (with-look-and-feel-realization
923     ((frame-manager *application-frame*) *application-frame*)
924     (multiple-value-bind (vbox new-pane) (make-pane-constellation)
925     (let* ((current-window (current-window))
926     (constellation-root (parent3 current-window)))
927 mvilleneuve 1.95 (setf (buffer new-pane) (buffer current-window)
928     (auto-fill-mode new-pane) (auto-fill-mode current-window)
929     (auto-fill-column new-pane) (auto-fill-column current-window))
930 rstrandh 1.83 (push new-pane (windows *application-frame*))
931     (replace-constellation constellation-root vbox nil)
932     (full-redisplay current-window)
933     (full-redisplay new-pane)))))
934    
935     (define-named-command com-other-window ()
936     (setf (windows *application-frame*)
937     (append (cdr (windows *application-frame*))
938     (list (car (windows *application-frame*))))))
939    
940     (define-named-command com-delete-window ()
941     (unless (null (cdr (windows *application-frame*)))
942     (let* ((constellation (parent3 (current-window)))
943     (box (sheet-parent constellation))
944     (box-children (sheet-children box))
945     (other (if (eq constellation (first box-children))
946     (second box-children)
947     (first box-children)))
948     (parent (sheet-parent box))
949     (children (sheet-children parent))
950     (first (first children))
951     (second (second children)))
952     (pop (windows *application-frame*))
953     (sheet-disown-child box other)
954     (cond ((eq box first)
955     (sheet-disown-child parent box)
956     (sheet-adopt-child parent other)
957     (reorder-sheets parent (list other second)))
958     (t
959     (sheet-disown-child parent box)
960     (sheet-adopt-child parent other)
961     (reorder-sheets parent (list first other)))))))
962 rstrandh 1.77
963 rstrandh 1.94 ;; (define-named-command com-delete-window ()
964     ;; (unless (null (cdr (windows *application-frame*)))
965     ;; (let* ((constellation (parent3 (current-window)))
966     ;; (box (sheet-parent constellation))
967     ;; (box-children (sheet-children box))
968     ;; (other (if (eq constellation (first box-children))
969     ;; (third box-children)
970     ;; (first box-children)))
971     ;; (parent (sheet-parent box))
972     ;; (children (sheet-children parent))
973     ;; (first (first children))
974     ;; (second (second children))
975     ;; (third (third children)))
976     ;; (pop (windows *application-frame*))
977     ;; (sheet-disown-child box other)
978     ;; (cond ((eq box first)
979     ;; (sheet-disown-child parent box)
980     ;; (sheet-adopt-child parent other)
981     ;; (reorder-sheets parent (list other second third)))
982     ;; (t
983     ;; (sheet-disown-child parent box)
984     ;; (sheet-adopt-child parent other)
985     ;; (reorder-sheets parent (list first second other)))))))
986    
987 ejohnson 1.27 ;;;;;;;;;;;;;;;;;;;;
988     ;; Kill ring commands
989    
990 ejohnson 1.31 ;; Copies an element from a kill-ring to a buffer at the given offset
991 ejohnson 1.50 (define-named-command com-yank ()
992 rstrandh 1.80 (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
993 ejohnson 1.27
994 ejohnson 1.31 ;; Destructively cut a given buffer region into the kill-ring
995 abridgewater 1.34 (define-named-command com-cut-out ()
996 rstrandh 1.80 (multiple-value-bind (start end) (region-limits (current-window))
997 mvilleneuve 1.64 (kill-ring-standard-push *kill-ring* (region-to-sequence start end))
998     (delete-region (offset start) end)))
999 ejohnson 1.27
1000 ejohnson 1.31 ;; Non destructively copies in buffer region to the kill ring
1001 abridgewater 1.34 (define-named-command com-copy-out ()
1002 rstrandh 1.80 (let ((pane (current-window)))
1003 rstrandh 1.70 (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
1004 ejohnson 1.27
1005 ejohnson 1.50 (define-named-command com-rotate-yank ()
1006 rstrandh 1.80 (let* ((pane (current-window))
1007 ejohnson 1.54 (point (point pane))
1008 ejohnson 1.50 (last-yank (kill-ring-yank *kill-ring*)))
1009 ejohnson 1.54 (if (eq (previous-command pane)
1010 ejohnson 1.50 'com-rotate-yank)
1011 ejohnson 1.54 (progn
1012     (delete-range point (* -1 (length last-yank)))
1013     (rotate-yank-position *kill-ring*)))
1014     (insert-sequence point (kill-ring-yank *kill-ring*))))
1015 ejohnson 1.27
1016 ejohnson 1.50 (define-named-command com-resize-kill-ring ()
1017 ejohnson 1.46 (let ((size (accept 'integer :prompt "New kill ring size")))
1018 ejohnson 1.50 (setf (kill-ring-max-size *kill-ring*) size)))
1019 rstrandh 1.47
1020 mvilleneuve 1.96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1021     ;;;
1022     ;;; Incremental search
1023    
1024 mvilleneuve 1.97 (defun isearch-command-loop (pane forwardp)
1025     (let ((point (point pane)))
1026 mvilleneuve 1.96 (unless (endp (isearch-states pane))
1027     (setf (isearch-previous-string pane)
1028     (search-string (first (isearch-states pane)))))
1029     (setf (isearch-mode pane) t)
1030     (setf (isearch-states pane)
1031     (list (make-instance 'isearch-state
1032     :search-string ""
1033 mvilleneuve 1.97 :search-mark (clone-mark point)
1034     :search-forward-p forwardp)))
1035 mvilleneuve 1.100 (simple-command-loop 'isearch-climacs-table
1036     (isearch-mode pane)
1037     ((setf (isearch-mode pane) nil)))))
1038 mvilleneuve 1.96
1039 mvilleneuve 1.97 (defun isearch-from-mark (pane mark string forwardp)
1040     (flet ((object-equal (x y)
1041     (if (characterp x)
1042     (and (characterp y) (char-equal x y))
1043     (eql x y))))
1044     (let* ((point (point pane))
1045     (mark2 (clone-mark mark))
1046     (success (funcall (if forwardp #'search-forward #'search-backward)
1047     mark2
1048     string
1049     :test #'object-equal)))
1050     (cond (success
1051     (setf (offset point) (offset mark2)
1052     (offset mark) (if forwardp
1053     (- (offset mark2) (length string))
1054     (+ (offset mark2) (length string))))
1055     (push (make-instance 'isearch-state
1056     :search-string string
1057     :search-mark mark
1058     :search-forward-p forwardp)
1059     (isearch-states pane)))
1060     (t
1061     (beep))))))
1062    
1063     (define-named-command com-isearch-mode-forward ()
1064     (isearch-command-loop (current-window) t))
1065    
1066     (define-named-command com-isearch-mode-backward ()
1067     (isearch-command-loop (current-window) nil))
1068 mvilleneuve 1.96
1069     (define-named-command com-isearch-append-char ()
1070     (let* ((pane (current-window))
1071     (states (isearch-states pane))
1072     (string (concatenate 'string
1073     (search-string (first states))
1074     (string *current-gesture*)))
1075     (mark (clone-mark (search-mark (first states))))
1076 mvilleneuve 1.97 (forwardp (search-forward-p (first states))))
1077     (unless forwardp
1078     (incf (offset mark)))
1079     (isearch-from-mark pane mark string forwardp)))
1080 mvilleneuve 1.96
1081     (define-named-command com-isearch-delete-char ()
1082     (let* ((pane (current-window)))
1083     (cond ((null (second (isearch-states pane)))
1084     (beep))
1085     (t
1086     (pop (isearch-states pane))
1087     (let ((state (first (isearch-states pane))))
1088     (setf (offset (point pane))
1089 mvilleneuve 1.97 (if (search-forward-p state)
1090     (+ (offset (search-mark state))
1091     (length (search-string state)))
1092     (- (offset (search-mark state))
1093     (length (search-string state))))))))))
1094 mvilleneuve 1.96
1095     (define-named-command com-isearch-forward ()
1096     (let* ((pane (current-window))
1097     (point (point pane))
1098     (states (isearch-states pane))
1099     (string (if (null (second states))
1100     (isearch-previous-string pane)
1101     (search-string (first states))))
1102 mvilleneuve 1.97 (mark (clone-mark point)))
1103     (isearch-from-mark pane mark string t)))
1104    
1105     (define-named-command com-isearch-backward ()
1106     (let* ((pane (current-window))
1107     (point (point pane))
1108     (states (isearch-states pane))
1109     (string (if (null (second states))
1110     (isearch-previous-string pane)
1111     (search-string (first states))))
1112     (mark (clone-mark point)))
1113     (isearch-from-mark pane mark string nil)))
1114 mvilleneuve 1.96
1115     (define-named-command com-isearch-exit ()
1116     (setf (isearch-mode (current-window)) nil))
1117    
1118 mvilleneuve 1.100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1119     ;;;
1120     ;;; Query replace
1121    
1122     (defun query-replace-find-next-match (mark string)
1123     (let ((offset-before (offset mark)))
1124     (search-forward mark string)
1125     (/= (offset mark) offset-before)))
1126    
1127     (define-named-command com-query-replace ()
1128     (let* ((string1 (accept 'string :prompt "Query replace"))
1129     (string2 (accept 'string
1130     :prompt (format nil "Query replace ~A with"
1131     string1)))
1132     (pane (current-window))
1133     (point (point pane)))
1134     (when (query-replace-find-next-match point string1)
1135     (setf (query-replace-state pane) (make-instance 'query-replace-state
1136     :string1 string1
1137     :string2 string2)
1138     (query-replace-mode pane) t)
1139     (simple-command-loop 'query-replace-climacs-table
1140     (query-replace-mode pane)
1141     ((setf (query-replace-mode pane) nil))))))
1142    
1143     (define-named-command com-query-replace-replace ()
1144     (let* ((pane (current-window))
1145     (point (point pane))
1146     (state (query-replace-state pane))
1147     (string1-length (length (string1 state))))
1148     (backward-object point string1-length)
1149     (delete-range point string1-length)
1150     (insert-sequence point (string2 state))
1151     (unless (query-replace-find-next-match point (string1 state))
1152     (setf (query-replace-mode pane) nil))))
1153    
1154     (define-named-command com-query-replace-skip ()
1155     (let* ((pane (current-window))
1156     (point (point pane))
1157     (state (query-replace-state pane)))
1158     (unless (query-replace-find-next-match point (string1 state))
1159     (setf (query-replace-mode pane) nil))))
1160    
1161     (define-named-command com-query-replace-exit ()
1162     (setf (query-replace-mode (current-window)) nil))
1163    
1164     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1165     ;;;
1166     ;;; Undo/redo
1167    
1168 rstrandh 1.98 (define-named-command com-undo ()
1169     (undo (undo-tree (buffer (current-window)))))
1170    
1171     (define-named-command com-redo ()
1172     (redo (undo-tree (buffer (current-window)))))
1173    
1174 mvilleneuve 1.96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1175     ;;;
1176     ;;; Dynamic abbrevs
1177 ejohnson 1.27
1178 rstrandh 1.49 (define-named-command com-dabbrev-expand ()
1179 rstrandh 1.80 (let* ((win (current-window))
1180 rstrandh 1.49 (point (point win)))
1181     (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win
1182     (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
1183     (setf (offset dabbrev-expansion-mark)
1184     (offset point))
1185     (forward-word dabbrev-expansion-mark))
1186     ((mark< dabbrev-expansion-mark point)
1187     (backward-object dabbrev-expansion-mark))
1188     (t (forward-object dabbrev-expansion-mark)))))
1189     (unless (or (beginning-of-buffer-p point)
1190     (not (constituentp (object-before point))))
1191     (unless (and (eq (previous-command win) 'com-dabbrev-expand)
1192     (not (null prefix-start-offset)))
1193     (setf dabbrev-expansion-mark (clone-mark point))
1194     (backward-word dabbrev-expansion-mark)
1195     (setf prefix-start-offset (offset dabbrev-expansion-mark))
1196     (setf original-prefix (region-to-sequence prefix-start-offset point))
1197     (move))
1198     (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
1199     (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
1200     (not (constituentp (object-before dabbrev-expansion-mark))))
1201     (looking-at dabbrev-expansion-mark original-prefix)))
1202     do (move))
1203     (if (end-of-buffer-p dabbrev-expansion-mark)
1204     (progn (delete-region prefix-start-offset point)
1205     (insert-sequence point original-prefix)
1206     (setf prefix-start-offset nil))
1207     (progn (delete-region prefix-start-offset point)
1208     (insert-sequence point
1209     (let ((offset (offset dabbrev-expansion-mark)))
1210     (prog2 (forward-word dabbrev-expansion-mark)
1211     (region-to-sequence offset dabbrev-expansion-mark)
1212     (setf (offset dabbrev-expansion-mark) offset))))
1213     (move))))))))
1214    
1215 rstrandh 1.71 (define-named-command com-beginning-of-paragraph ()
1216 rstrandh 1.80 (let* ((pane (current-window))
1217 rstrandh 1.71 (point (point pane))
1218     (syntax (syntax (buffer pane))))
1219     (beginning-of-paragraph point syntax)))
1220    
1221     (define-named-command com-end-of-paragraph ()
1222 rstrandh 1.80 (let* ((pane (current-window))
1223 rstrandh 1.71 (point (point pane))
1224     (syntax (syntax (buffer pane))))
1225     (end-of-paragraph point syntax)))
1226    
1227 ejohnson 1.27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1228     ;;;
1229 rstrandh 1.80 ;;; Global and dead-escape command tables
1230 ejohnson 1.27
1231     (make-command-table 'global-climacs-table :errorp nil)
1232    
1233 rstrandh 1.80 (make-command-table 'dead-escape-climacs-table :errorp nil)
1234    
1235     (add-menu-item-to-command-table 'global-climacs-table "dead-escape"
1236     :menu 'dead-escape-climacs-table
1237     :keystroke '(:escape))
1238    
1239     (defun dead-escape-set-key (gesture command)
1240     (add-command-to-command-table command 'dead-escape-climacs-table
1241     :keystroke gesture :errorp nil))
1242    
1243 ejohnson 1.27 (defun global-set-key (gesture command)
1244     (add-command-to-command-table command 'global-climacs-table
1245 rstrandh 1.80 :keystroke gesture :errorp nil)
1246     (when (and
1247     (listp gesture)
1248     (find :meta gesture))
1249     (dead-escape-set-key (remove :meta gesture) command)))
1250 ejohnson 1.27
1251 mvilleneuve 1.89 (loop for code from (char-code #\Space) to (char-code #\~)
1252 ejohnson 1.27 do (global-set-key (code-char code) 'com-self-insert))
1253    
1254 mvilleneuve 1.89 (global-set-key #\Newline 'com-self-insert)
1255 mvilleneuve 1.86 (global-set-key #\Tab 'com-indent-line)
1256 mvilleneuve 1.79 (global-set-key '(#\j :control) 'com-newline-and-indent)
1257 rstrandh 1.62 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
1258     (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
1259 ejohnson 1.27 (global-set-key '(#\a :control) 'com-beginning-of-line)
1260     (global-set-key '(#\e :control) 'com-end-of-line)
1261 rstrandh 1.62 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
1262 ejohnson 1.27 (global-set-key '(#\p :control) 'com-previous-line)
1263 rstrandh 1.75 (global-set-key '(#\l :control) 'com-full-redisplay)
1264 ejohnson 1.27 (global-set-key '(#\n :control) 'com-next-line)
1265     (global-set-key '(#\o :control) 'com-open-line)
1266     (global-set-key '(#\k :control) 'com-kill-line)
1267 rstrandh 1.42 (global-set-key '(#\t :control) 'com-transpose-objects)
1268 ejohnson 1.27 (global-set-key '(#\Space :control) 'com-set-mark)
1269 ejohnson 1.50 (global-set-key '(#\y :control) 'com-yank)
1270 ejohnson 1.27 (global-set-key '(#\w :control) 'com-cut-out)
1271 rstrandh 1.102 (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*))
1272     (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*))
1273 rstrandh 1.43 (global-set-key '(#\t :meta) 'com-transpose-words)
1274 rstrandh 1.60 (global-set-key '(#\u :meta) 'com-upcase-word)
1275     (global-set-key '(#\l :meta) 'com-downcase-word)
1276     (global-set-key '(#\c :meta) 'com-capitalize-word)
1277 ejohnson 1.27 (global-set-key '(#\x :meta) 'com-extended-command)
1278 ejohnson 1.50 (global-set-key '(#\y :meta) 'com-rotate-yank)
1279 ejohnson 1.27 (global-set-key '(#\w :meta) 'com-copy-out)
1280 rstrandh 1.39 (global-set-key '(#\v :control) 'com-page-down)
1281 rstrandh 1.40 (global-set-key '(#\v :meta) 'com-page-up)
1282 ejohnson 1.27 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
1283     (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
1284 rstrandh 1.32 (global-set-key '(#\m :meta) 'com-back-to-indentation)
1285 mvilleneuve 1.74 (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
1286 mvilleneuve 1.90 (global-set-key '(#\q :meta) 'com-fill-paragraph)
1287 rstrandh 1.32 (global-set-key '(#\d :meta) 'com-delete-word)
1288     (global-set-key '(#\Backspace :meta) 'com-backward-delete-word)
1289 rstrandh 1.49 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
1290 rstrandh 1.71 (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph)
1291     (global-set-key '(#\e :control :meta) 'com-end-of-paragraph)
1292 mvilleneuve 1.97 (global-set-key '(#\s :control) 'com-isearch-mode-forward)
1293     (global-set-key '(#\r :control) 'com-isearch-mode-backward)
1294 mvilleneuve 1.100 (global-set-key '(#\% :shift :meta) 'com-query-replace)
1295 ejohnson 1.27
1296     (global-set-key '(:up) 'com-previous-line)
1297     (global-set-key '(:down) 'com-next-line)
1298 rstrandh 1.62 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
1299 ejohnson 1.66 (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
1300 rstrandh 1.102 (global-set-key '(:left :control) `(com-backward-word ,*numeric-argument-marker*))
1301     (global-set-key '(:right :control) `(com-forward-word ,*numeric-argument-marker*))
1302 ejohnson 1.27 (global-set-key '(:home) 'com-beginning-of-line)
1303     (global-set-key '(:end) 'com-end-of-line)
1304 abridgewater 1.57 (global-set-key '(:prior) 'com-page-up)
1305     (global-set-key '(:next) 'com-page-down)
1306 ejohnson 1.27 (global-set-key '(:home :control) 'com-beginning-of-buffer)
1307     (global-set-key '(:end :control) 'com-end-of-buffer)
1308 rstrandh 1.62 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
1309     (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
1310 abakic 1.58
1311     (global-set-key '(:insert) 'com-toggle-overwrite-mode)
1312 ejohnson 1.27
1313     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1314     ;;;
1315     ;;; C-x command table
1316    
1317     (make-command-table 'c-x-climacs-table :errorp nil)
1318    
1319     (add-menu-item-to-command-table 'global-climacs-table "C-x"
1320     :menu 'c-x-climacs-table
1321     :keystroke '(#\x :control))
1322    
1323     (defun c-x-set-key (gesture command)
1324     (add-command-to-command-table command 'c-x-climacs-table
1325     :keystroke gesture :errorp nil))
1326    
1327 rstrandh 1.83 (c-x-set-key '(#\0) 'com-delete-window)
1328 rstrandh 1.77 (c-x-set-key '(#\2) 'com-split-window-vertically)
1329 rstrandh 1.83 (c-x-set-key '(#\3) 'com-split-window-horizontally)
1330 rstrandh 1.85 (c-x-set-key '(#\() 'com-start-kbd-macro)
1331     (c-x-set-key '(#\)) 'com-end-kbd-macro)
1332 rstrandh 1.75 (c-x-set-key '(#\b) 'com-switch-to-buffer)
1333 rstrandh 1.85 (c-x-set-key '(#\e) 'com-call-last-kbd-macro)
1334 ejohnson 1.27 (c-x-set-key '(#\c :control) 'com-quit)
1335     (c-x-set-key '(#\f :control) 'com-find-file)
1336 rstrandh 1.91 (c-x-set-key '(#\k) 'com-kill-buffer)
1337 rstrandh 1.63 (c-x-set-key '(#\l :control) 'com-load-file)
1338 rstrandh 1.83 (c-x-set-key '(#\o) 'com-other-window)
1339 rstrandh 1.98 (c-x-set-key '(#\r) 'com-redo)
1340     (c-x-set-key '(#\u) 'com-undo)
1341 ejohnson 1.27 (c-x-set-key '(#\s :control) 'com-save-buffer)
1342 rstrandh 1.45 (c-x-set-key '(#\t :control) 'com-transpose-lines)
1343 ejohnson 1.27 (c-x-set-key '(#\w :control) 'com-write-buffer)
1344 rstrandh 1.45 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
1345 rstrandh 1.44
1346     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1347     ;;;
1348     ;;; Some Unicode stuff
1349    
1350     (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
1351 rstrandh 1.80 (insert-object (point (current-window)) (code-char code)))
1352 rstrandh 1.44
1353     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1354     ;;;
1355     ;;; Dead-acute command table
1356    
1357     (make-command-table 'dead-acute-climacs-table :errorp nil)
1358    
1359     (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
1360     :menu 'dead-acute-climacs-table
1361     :keystroke '(:dead--acute))
1362    
1363     (defun dead-acute-set-key (gesture command)
1364     (add-command-to-command-table command 'dead-acute-climacs-table
1365     :keystroke gesture :errorp nil))
1366    
1367     (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
1368     (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
1369     (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
1370     (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
1371     (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
1372     (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
1373     (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
1374     (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
1375     (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
1376     (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
1377     (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
1378     (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
1379     (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
1380     (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
1381     (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
1382     (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
1383     (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
1384     (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
1385     (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
1386     (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
1387    
1388 rstrandh 1.45 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
1389    
1390     (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
1391     :menu 'dead-acute-dead-accute-climacs-table
1392     :keystroke '(:dead--acute))
1393    
1394     (defun dead-acute-dead-accute-set-key (gesture command)
1395     (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
1396     :keystroke gesture :errorp nil))
1397    
1398     (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
1399     (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
1400 rstrandh 1.44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1401     ;;;
1402     ;;; Dead-grave command table
1403    
1404     (make-command-table 'dead-grave-climacs-table :errorp nil)
1405    
1406     (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
1407     :menu 'dead-grave-climacs-table
1408     :keystroke '(:dead--grave))
1409    
1410     (defun dead-grave-set-key (gesture command)
1411     (add-command-to-command-table command 'dead-grave-climacs-table
1412     :keystroke gesture :errorp nil))
1413    
1414     (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
1415     (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
1416     (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
1417     (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
1418     (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
1419     (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
1420     (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
1421     (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
1422     (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
1423     (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
1424     (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
1425    
1426     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1427     ;;;
1428     ;;; Dead-diaeresis command table
1429    
1430     (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
1431    
1432     (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
1433     :menu 'dead-diaeresis-climacs-table
1434     :keystroke '(:dead--diaeresis :shift))
1435    
1436     (defun dead-diaeresis-set-key (gesture command)
1437     (add-command-to-command-table command 'dead-diaeresis-climacs-table
1438     :keystroke gesture :errorp nil))
1439    
1440     (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
1441     (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
1442     (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
1443     (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
1444     (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
1445     (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
1446     (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
1447     (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
1448     (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
1449     (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
1450     (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
1451     (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
1452    
1453     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1454     ;;;
1455     ;;; Dead-tilde command table
1456    
1457     (make-command-table 'dead-tilde-climacs-table :errorp nil)
1458    
1459     (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
1460     :menu 'dead-tilde-climacs-table
1461     :keystroke '(:dead--tilde :shift))
1462    
1463     (defun dead-tilde-set-key (gesture command)
1464     (add-command-to-command-table command 'dead-tilde-climacs-table
1465     :keystroke gesture :errorp nil))
1466    
1467     (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
1468     (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
1469     (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
1470     (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
1471     (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
1472     (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
1473     (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
1474     (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
1475     (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
1476     (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
1477     (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
1478    
1479     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1480     ;;;
1481     ;;; Dead-circumflex command table
1482    
1483     (make-command-table 'dead-circumflex-climacs-table :errorp nil)
1484    
1485     (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
1486     :menu 'dead-circumflex-climacs-table
1487     :keystroke '(:dead--circumflex :shift))
1488    
1489     (defun dead-circumflex-set-key (gesture command)
1490     (add-command-to-command-table command 'dead-circumflex-climacs-table
1491     :keystroke gesture :errorp nil))
1492    
1493     (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
1494     (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
1495     (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
1496     (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
1497     (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
1498     (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
1499     (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
1500     (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
1501     (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
1502     (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
1503     (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))
1504 mvilleneuve 1.96
1505     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1506     ;;;
1507     ;;; Isearch command table
1508    
1509     (make-command-table 'isearch-climacs-table :errorp nil)
1510    
1511     (defun isearch-set-key (gesture command)
1512     (add-command-to-command-table command 'isearch-climacs-table
1513     :keystroke gesture :errorp nil))
1514    
1515     (loop for code from (char-code #\Space) to (char-code #\~)
1516     do (isearch-set-key (code-char code) 'com-isearch-append-char))
1517    
1518     (isearch-set-key '(#\Newline) 'com-isearch-exit)
1519     (isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
1520     (isearch-set-key '(#\s :control) 'com-isearch-forward)
1521 mvilleneuve 1.97 (isearch-set-key '(#\r :control) 'com-isearch-backward)
1522 mvilleneuve 1.100
1523     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1524     ;;;
1525     ;;; Query replace command table
1526    
1527     (make-command-table 'query-replace-climacs-table :errorp nil)
1528    
1529     (defun query-replace-set-key (gesture command)
1530     (add-command-to-command-table command 'query-replace-climacs-table
1531     :keystroke gesture :errorp nil))
1532    
1533     (query-replace-set-key '(#\Newline) 'com-query-replace-exit)
1534     (query-replace-set-key '(#\Space) 'com-query-replace-replace)
1535     (query-replace-set-key '(#\Backspace) 'com-query-replace-skip)
1536     (query-replace-set-key '(#\Rubout) 'com-query-replace-skip)
1537     (query-replace-set-key '(#\q) 'com-query-replace-exit)
1538     (query-replace-set-key '(#\y) 'com-query-replace-replace)
1539     (query-replace-set-key '(#\n) 'com-query-replace-skip)

  ViewVC Help
Powered by ViewVC 1.1.5