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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5