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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.170 - (show annotations)
Fri Aug 5 12:40:56 2005 UTC (8 years, 8 months ago) by dmurray
Branch: MAIN
Changes since 1.169: +136 -32 lines
Added and altered various commands.

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

  ViewVC Help
Powered by ViewVC 1.1.5