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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.149 - (show annotations)
Sat Jul 2 15:54:22 2005 UTC (8 years, 9 months ago) by crhodes
Branch: MAIN
Changes since 1.148: +1 -1 lines
Experimental fix for CSR minibuffer problems.

Oddly, not everyone suffers from this.  Nor from the problem the
handle-repaint method was included to solve: the scrollbars not
adjusting properly.

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

  ViewVC Help
Powered by ViewVC 1.1.5