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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.166 - (hide annotations)
Tue Jul 26 05:28:39 2005 UTC (8 years, 8 months ago) by rstrandh
Branch: MAIN
Changes since 1.165: +14 -0 lines
Improvements to Lisp syntax.
(thanks to John Q Splittist)

Here is his own description of these improvements:

This patch:

* fixes presentations of multi-token symbols and strings
* introduces a new presentation type, the 'unknown-symbol, for symbol
tokens that haven't got a package in the image (because, eg. the file
hasn't been loaded)
* introduces a new presentation type, the 'lisp-string, for strings in
the file surrounded by #\"s
* presents every token as a 'string.

Also included is a presentation translator from 'lisp-string to 'string
that doesn't work. It ought to, and I seem to have got back into the
gesture/pointer-event code with things still making (to me) sense, so
I'd be grateful if someone could check whether it works for them.

Things to play with:

* M-x Accept String (most things mouseable)
* M-x Accept Symbol (see what the system can find, and where - 'symbols
are returned as the actual symbol; 'unknown-symbols are returned as strings
* M-x Accept Lisp String (source code strings are mouseable)
* M-% [being Query Replace], then mouse and click to choose the strings!

Things to think about:

* Should 'string be for actual lisp strings, and (say) ESA-string (or
editor-string) be for sequences of objects in the buffer? This makes
sense to me, as some commands that accept a sequence of objects from the
buffer might be usable in non-text-editor contexts. (Simply changing
commands like com-query-replace from (accept 'string ...) to (accept
'esa-string ...), and changing a couple of things in lisp-syntax, would
work.)
* What other things might it be useful to mouse around with?
* Is there a natural meaning for simply clicking on something in the buffer?

Things to do:

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

  ViewVC Help
Powered by ViewVC 1.1.5