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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5