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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5