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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5