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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.84 - (show annotations)
Wed Jan 19 05:28:38 2005 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.83: +4 -2 lines
find-file does not create the file if it does not exist.
(thanks to Lawrence Mitchell)
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 (:panes
55 (win (let* ((extended-pane
56 (make-pane 'extended-pane
57 :width 900 :height 400
58 :name 'bla
59 :incremental-redisplay t
60 :display-function 'display-win))
61 (info-pane
62 (make-pane 'info-pane
63 :climacs-pane extended-pane
64 :width 900 :height 20 :max-height 20 :min-height 20
65 ::background +gray85+
66 :scroll-bars nil
67 :borders nil
68 :incremental-redisplay t
69 :display-function 'display-info)))
70 (vertically ()
71 (scrolling ()
72 extended-pane)
73 info-pane)))
74 (int (make-pane 'minibuffer-pane
75 :width 900 :height 20 :max-height 20 :min-height 20
76 :scroll-bars nil)))
77 (:layouts
78 (default
79 (vertically (:scroll-bars nil)
80 win
81 int)))
82 (:top-level (climacs-top-level)))
83
84 (defmacro current-window ()
85 `(car (windows *application-frame*)))
86
87 (defmethod redisplay-frame-panes :around ((frame climacs) &rest args)
88 (declare (ignore args))
89 (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame)))))
90 (loop for buffer in buffers
91 do (update-syntax buffer (syntax buffer)))
92 (call-next-method)
93 (loop for buffer in buffers
94 do (clear-modify buffer))))
95
96 (defun climacs ()
97 "Starts up a climacs session"
98 (let ((frame (make-application-frame 'climacs)))
99 (run-frame-top-level frame)))
100
101 (defun display-message (format-string &rest format-args)
102 (apply #'format *standard-input* format-string format-args))
103
104 (defun display-info (frame pane)
105 (declare (ignore frame))
106 (with-slots (climacs-pane) pane
107 (let* ((buf (buffer climacs-pane))
108 (name-info (format nil " ~a ~a Syntax: ~a ~a"
109 (if (needs-saving buf) "**" "--")
110 (name buf)
111 (name (syntax buf))
112 (if (slot-value climacs-pane 'overwrite-mode)
113 "Ovwrt"
114 ""))))
115 (princ name-info pane))))
116
117 (defun display-win (frame pane)
118 "The display function used by the climacs application frame."
119 (declare (ignore frame))
120 (redisplay-pane pane (eq pane (car (windows *application-frame*)))))
121
122 (defun find-gestures (gestures start-table)
123 (loop with table = (find-command-table start-table)
124 for (gesture . rest) on gestures
125 for item = (find-keystroke-item gesture table :errorp nil)
126 while item
127 do (if (eq (command-menu-item-type item) :command)
128 (return (if (null rest) item nil))
129 (setf table (command-menu-item-value item)))
130 finally (return item)))
131
132 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
133 (defparameter *current-gesture* nil)
134
135 (defun meta-digit (gesture)
136 (position gesture
137 '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)
138 (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
139 :test #'event-matches-gesture-name-p))
140
141 (defun climacs-read-gesture ()
142 (loop for gesture = (read-gesture :stream *standard-input*)
143 when (event-matches-gesture-name-p gesture '(#\g :control))
144 do (throw 'outer-loop nil)
145 until (or (characterp gesture)
146 (and (typep gesture 'keyboard-event)
147 (or (keyboard-event-character gesture)
148 (not (member (keyboard-event-key-name
149 gesture)
150 '(:control-left :control-right
151 :shift-left :shift-right
152 :meta-left :meta-right
153 :super-left :super-right
154 :hyper-left :hyper-right
155 :shift-lock :caps-lock
156 :alt-left :alt-right))))))
157 finally (return gesture)))
158
159 (defun read-numeric-argument (&key (stream *standard-input*))
160 (let ((gesture (climacs-read-gesture)))
161 (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
162 (let ((numarg 4))
163 (loop for gesture = (climacs-read-gesture)
164 while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
165 do (setf numarg (* 4 numarg))
166 finally (unread-gesture gesture :stream stream))
167 (let ((gesture (climacs-read-gesture)))
168 (cond ((and (characterp gesture)
169 (digit-char-p gesture 10))
170 (setf numarg (- (char-code gesture) (char-code #\0)))
171 (loop for gesture = (climacs-read-gesture)
172 while (and (characterp gesture)
173 (digit-char-p gesture 10))
174 do (setf numarg (+ (* 10 numarg)
175 (- (char-code gesture) (char-code #\0))))
176 finally (unread-gesture gesture :stream stream)
177 (return (values numarg t))))
178 (t
179 (unread-gesture gesture :stream stream)
180 (values numarg t))))))
181 ((meta-digit gesture)
182 (let ((numarg (meta-digit gesture)))
183 (loop for gesture = (climacs-read-gesture)
184 while (meta-digit gesture)
185 do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
186 finally (unread-gesture gesture :stream stream)
187 (return (values numarg t)))))
188 (t (unread-gesture gesture :stream stream)
189 (values 1 nil)))))
190
191 ;;; we know the vbox pane has a scroller pane and an info
192 ;;; pane in it. The scroller pane has a viewport in it,
193 ;;; and the viewport contains the climacs-pane as its only child.
194 (defun find-climacs-pane (vbox)
195 (first (sheet-children
196 (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane))
197 (sheet-children
198 (find-if (lambda (pane) (typep pane 'scroller-pane))
199 (sheet-children vbox)))))))
200
201 (defun climacs-top-level (frame &key
202 command-parser command-unparser
203 partial-command-parser prompt)
204 (declare (ignore command-parser command-unparser partial-command-parser prompt))
205 (with-slots (windows) frame
206 (setf windows (list (find-climacs-pane (find-pane-named frame 'win))))
207 (push (buffer (car windows)) (buffers frame))
208 (let ((*standard-output* (car windows))
209 (*standard-input* (find-pane-named frame 'int))
210 (*print-pretty* nil)
211 (*abort-gestures* nil))
212 (redisplay-frame-panes frame :force-p t)
213 (loop (catch 'outer-loop
214 (loop for gestures = '()
215 for numarg = (read-numeric-argument :stream *standard-input*)
216 do (loop (setf *current-gesture* (climacs-read-gesture))
217 (setf gestures (nconc gestures (list *current-gesture*)))
218 (let ((item (find-gestures gestures 'global-climacs-table)))
219 (cond ((not item)
220 (beep) (return))
221 ((eq (command-menu-item-type item) :command)
222 (let ((command (command-menu-item-value item)))
223 (unless (consp command)
224 (setf command (list command)))
225 (setf command (substitute-numeric-argument-marker command numarg))
226 (handler-case
227 (execute-frame-command frame command)
228 (error (condition)
229 (beep)
230 (format *error-output* "~a~%" condition)))
231 (setf (previous-command *standard-output*)
232 (if (consp command)
233 (car command)
234 command))
235 (return)))
236 (t nil))))
237 (let ((buffer (buffer (current-window))))
238 (when (modified-p buffer)
239 (setf (needs-saving buffer) t)))
240 (redisplay-frame-panes frame)))
241 (beep)
242 (let ((buffer (buffer (current-window))))
243 (when (modified-p buffer)
244 (setf (needs-saving buffer) t)))
245 (redisplay-frame-panes frame)))))
246
247 (defun region-limits (pane)
248 (if (mark< (mark pane) (point pane))
249 (values (mark pane) (point pane))
250 (values (point pane) (mark pane))))
251
252 (defmacro define-named-command (command-name args &body body)
253 `(define-climacs-command ,(if (listp command-name)
254 `(,@command-name :name t)
255 `(,command-name :name t)) ,args ,@body))
256
257 (define-named-command (com-quit) ()
258 (frame-exit *application-frame*))
259
260 (define-named-command com-toggle-overwrite-mode ()
261 (let ((win (current-window)))
262 (setf (slot-value win 'overwrite-mode)
263 (not (slot-value win 'overwrite-mode)))))
264
265 (define-command com-self-insert ()
266 (let* ((win (current-window))
267 (point (point win)))
268 (unless (constituentp *current-gesture*)
269 (possibly-expand-abbrev point))
270 (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point)))
271 (progn
272 (delete-range point)
273 (insert-object point *current-gesture*))
274 (insert-object point *current-gesture*))))
275
276 (define-named-command com-beginning-of-line ()
277 (beginning-of-line (point (current-window))))
278
279 (define-named-command com-end-of-line ()
280 (end-of-line (point (current-window))))
281
282 (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
283 (delete-range (point (current-window)) count))
284
285 (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
286 (delete-range (point (current-window)) (- count)))
287
288 (define-named-command com-transpose-objects ()
289 (let* ((point (point (current-window))))
290 (unless (beginning-of-buffer-p point)
291 (when (end-of-line-p point)
292 (backward-object point))
293 (let ((object (object-after point)))
294 (delete-range point)
295 (backward-object point)
296 (insert-object point object)
297 (forward-object point)))))
298
299 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
300 (backward-object (point (current-window)) count))
301
302 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
303 (forward-object (point (current-window)) count))
304
305 (define-named-command com-transpose-words ()
306 (let* ((point (point (current-window))))
307 (let (bw1 bw2 ew1 ew2)
308 (backward-word point)
309 (setf bw1 (offset point))
310 (forward-word point)
311 (setf ew1 (offset point))
312 (forward-word point)
313 (when (= (offset point) ew1)
314 ;; this is emacs' message in the minibuffer
315 (error "Don't have two things to transpose"))
316 (setf ew2 (offset point))
317 (backward-word point)
318 (setf bw2 (offset point))
319 (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
320 (w1 (buffer-sequence (buffer point) bw1 ew1)))
321 (delete-word point)
322 (insert-sequence point w1)
323 (backward-word point)
324 (backward-word point)
325 (delete-word point)
326 (insert-sequence point w2)
327 (forward-word point)))))
328
329 (define-named-command com-transpose-lines ()
330 (let ((point (point (current-window))))
331 (beginning-of-line point)
332 (unless (beginning-of-buffer-p point)
333 (previous-line point))
334 (let* ((bol (offset point))
335 (eol (progn (end-of-line point)
336 (offset point)))
337 (line (buffer-sequence (buffer point) bol eol)))
338 (delete-region bol point)
339 ;; Remove newline at end of line as well.
340 (unless (end-of-buffer-p point)
341 (delete-range point))
342 ;; If the current line is at the end of the buffer, we want to
343 ;; be able to insert past it, so we need to get an extra line
344 ;; at the end.
345 (end-of-line point)
346 (when (end-of-buffer-p point)
347 (insert-object point #\Newline))
348 (next-line point 0)
349 (insert-sequence point line)
350 (insert-object point #\Newline))))
351
352 (define-named-command com-previous-line ()
353 (let* ((win (current-window))
354 (point (point win)))
355 (unless (or (eq (previous-command win) 'com-previous-line)
356 (eq (previous-command win) 'com-next-line))
357 (setf (slot-value win 'goal-column) (column-number point)))
358 (previous-line point (slot-value win 'goal-column))))
359
360 (define-named-command com-next-line ()
361 (let* ((win (current-window))
362 (point (point win)))
363 (unless (or (eq (previous-command win) 'com-previous-line)
364 (eq (previous-command win) 'com-next-line))
365 (setf (slot-value win 'goal-column) (column-number point)))
366 (next-line point (slot-value win 'goal-column))))
367
368 (define-named-command com-open-line ()
369 (open-line (point (current-window))))
370
371 (define-named-command com-kill-line ()
372 (let* ((pane (current-window))
373 (point (point pane))
374 (mark (offset point)))
375 (cond ((end-of-buffer-p point) nil)
376 ((end-of-line-p point)(forward-object point))
377 (t
378 (end-of-line point)
379 (cond ((beginning-of-buffer-p point) nil)
380 ((beginning-of-line-p point)(forward-object point)))))
381 (if (eq (previous-command pane) 'com-kill-line)
382 (kill-ring-concatenating-push *kill-ring*
383 (region-to-sequence mark point))
384 (kill-ring-standard-push *kill-ring*
385 (region-to-sequence mark point)))
386 (delete-region mark point)))
387
388 (define-named-command com-forward-word ()
389 (forward-word (point (current-window))))
390
391 (define-named-command com-backward-word ()
392 (backward-word (point (current-window))))
393
394 (define-named-command com-delete-word ()
395 (delete-word (point (current-window))))
396
397 (define-named-command com-backward-delete-word ()
398 (backward-delete-word (point (current-window))))
399
400 (define-named-command com-upcase-region ()
401 (multiple-value-bind (start end) (region-limits (current-window))
402 (upcase-region start end)))
403
404 (define-named-command com-downcase-region ()
405 (multiple-value-bind (start end) (region-limits (current-window))
406 (downcase-region start end)))
407
408 (define-named-command com-capitalize-region ()
409 (multiple-value-bind (start end) (region-limits (current-window))
410 (capitalize-region start end)))
411
412 (define-named-command com-upcase-word ()
413 (upcase-word (point (current-window))))
414
415 (define-named-command com-downcase-word ()
416 (downcase-word (point (current-window))))
417
418 (define-named-command com-capitalize-word ()
419 (capitalize-word (point (current-window))))
420
421 (define-named-command com-tabify-region ()
422 (let ((pane (current-window)))
423 (multiple-value-bind (start end) (region-limits pane)
424 (tabify-region start end (tab-space-count (stream-default-view pane))))))
425
426 (define-named-command com-untabify-region ()
427 (let ((pane (current-window)))
428 (multiple-value-bind (start end) (region-limits pane)
429 (untabify-region start end (tab-space-count (stream-default-view pane))))))
430
431 (defun indent-current-line (pane point)
432 (let* ((buffer (buffer pane))
433 (view (stream-default-view pane))
434 (tab-space-count (tab-space-count view))
435 (indentation (syntax-line-indentation point
436 tab-space-count
437 (syntax buffer))))
438 (indent-line point indentation (and (indent-tabs-mode buffer)
439 tab-space-count))))
440
441 (define-named-command com-indent-line ()
442 (let* ((pane (current-window))
443 (point (point pane)))
444 (indent-current-line pane point)))
445
446 (define-named-command com-newline-and-indent ()
447 (let* ((pane (current-window))
448 (point (point pane)))
449 (insert-object point #\Newline)
450 (indent-current-line pane point)))
451
452 (define-named-command com-delete-indentation ()
453 (delete-indentation (point (current-window))))
454
455 (define-command com-extended-command ()
456 (let ((item (accept 'command :prompt "Extended Command")))
457 (execute-frame-command *application-frame* item)))
458
459 (eval-when (:compile-toplevel :load-toplevel)
460 (define-presentation-type completable-pathname ()
461 :inherit-from 'pathname))
462
463 (defun filename-completer (so-far mode)
464 (flet ((remove-trail (s)
465 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
466 (if pos (1+ pos) 0)))))
467 (let* ((directory-prefix
468 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
469 ""
470 (namestring #+sbcl *default-pathname-defaults*
471 #+cmu (ext:default-directory)
472 #-(or sbcl cmu) *default-pathname-defaults*)))
473 (full-so-far (concatenate 'string directory-prefix so-far))
474 (pathnames
475 (loop with length = (length full-so-far)
476 for path in (directory (concatenate 'string
477 (remove-trail so-far)
478 "*.*"))
479 when (let ((mismatch (mismatch (namestring path) full-so-far)))
480 (or (null mismatch) (= mismatch length)))
481 collect path))
482 (strings (mapcar #'namestring pathnames))
483 (first-string (car strings))
484 (length-common-prefix nil)
485 (completed-string nil)
486 (full-completed-string nil))
487 (unless (null pathnames)
488 (setf length-common-prefix
489 (loop with length = (length first-string)
490 for string in (cdr strings)
491 do (setf length (min length (or (mismatch string first-string) length)))
492 finally (return length))))
493 (unless (null pathnames)
494 (setf completed-string
495 (subseq first-string (length directory-prefix)
496 (if (null (cdr pathnames)) nil length-common-prefix)))
497 (setf full-completed-string
498 (concatenate 'string directory-prefix completed-string)))
499 (case mode
500 ((:complete-limited :complete-maximal)
501 (cond ((null pathnames)
502 (values so-far nil nil 0 nil))
503 ((null (cdr pathnames))
504 (values completed-string t (car pathnames) 1 nil))
505 (t
506 (values completed-string nil nil (length pathnames) nil))))
507 (:complete
508 (cond ((null pathnames)
509 (values so-far t so-far 1 nil))
510 ((null (cdr pathnames))
511 (values completed-string t (car pathnames) 1 nil))
512 ((find full-completed-string strings :test #'string-equal)
513 (let ((pos (position full-completed-string strings :test #'string-equal)))
514 (values completed-string
515 t (elt pathnames pos) (length pathnames) nil)))
516 (t
517 (values completed-string nil nil (length pathnames) nil))))
518 (:possibilities
519 (values nil nil nil (length pathnames)
520 (loop with length = (length directory-prefix)
521 for name in pathnames
522 collect (list (subseq (namestring name) length nil)
523 name))))))))
524
525 (define-presentation-method accept
526 ((type completable-pathname) stream (view textual-view) &key)
527 (multiple-value-bind (pathname success string)
528 (complete-input stream
529 #'filename-completer
530 :partial-completers '(#\Space)
531 :allow-any-input t)
532 (declare (ignore success))
533 (or pathname string)))
534
535 (defun pathname-filename (pathname)
536 (if (null (pathname-type pathname))
537 (pathname-name pathname)
538 (concatenate 'string (pathname-name pathname)
539 "." (pathname-type pathname))))
540
541 (define-named-command com-find-file ()
542 (let ((filename (accept 'completable-pathname
543 :prompt "Find File"))
544 (buffer (make-instance 'climacs-buffer))
545 (pane (current-window)))
546 (push buffer (buffers *application-frame*))
547 (setf (buffer (current-window)) buffer)
548 (setf (syntax buffer) (make-instance 'basic-syntax))
549 ;; Don't want to create the file if it doesn't exist.
550 (when (probe-file filename)
551 (with-open-file (stream filename :direction :input)
552 (input-from-stream stream buffer 0)))
553 (setf (filename buffer) filename
554 (name buffer) (pathname-filename filename)
555 (needs-saving buffer) nil)
556 (beginning-of-buffer (point pane))
557 ;; this one is needed so that the buffer modification protocol
558 ;; resets the low and high marks after redisplay
559 (redisplay-frame-panes *application-frame*)))
560
561 (define-named-command com-save-buffer ()
562 (let* ((buffer (buffer (current-window)))
563 (filename (or (filename buffer)
564 (accept 'completable-pathname
565 :prompt "Save Buffer to File"))))
566 (if (or (null (filename buffer))
567 (needs-saving buffer))
568 (progn (with-open-file (stream filename :direction :output :if-exists :supersede)
569 (output-to-stream stream buffer 0 (size buffer)))
570 (setf (filename buffer) filename
571 (name buffer) (pathname-filename filename))
572 (display-message "Wrote: ~a" (filename buffer)))
573 (display-message "No changes need to be saved from ~a" (name buffer)))
574 (setf (needs-saving buffer) nil)))
575
576 (define-named-command com-write-buffer ()
577 (let ((filename (accept 'completable-pathname
578 :prompt "Write Buffer to File"))
579 (buffer (buffer (current-window))))
580 (with-open-file (stream filename :direction :output :if-exists :supersede)
581 (output-to-stream stream buffer 0 (size buffer)))
582 (setf (filename buffer) filename
583 (name buffer) (pathname-filename filename)
584 (needs-saving buffer) nil)
585 (display-message "Wrote: ~a" (filename buffer))))
586
587 (define-presentation-method accept
588 ((type buffer) stream (view textual-view) &key)
589 (multiple-value-bind (object success string)
590 (complete-input stream
591 (lambda (so-far action)
592 (complete-from-possibilities
593 so-far (buffers *application-frame*) '() :action action
594 :name-key #'name
595 :value-key #'identity))
596 :partial-completers '(#\Space)
597 :allow-any-input t)
598 (declare (ignore success))
599 (or object
600 (car (push (make-instance 'climacs-buffer :name string)
601 (buffers *application-frame*))))))
602
603 (define-named-command com-switch-to-buffer ()
604 (let ((buffer (accept 'buffer
605 :prompt "Switch to buffer")))
606 (setf (buffer (current-window)) buffer)
607 (setf (syntax buffer) (make-instance 'basic-syntax))
608 (beginning-of-buffer (point (current-window)))
609 (full-redisplay (current-window))))
610
611 (define-named-command com-full-redisplay ()
612 (full-redisplay (current-window)))
613
614 (define-named-command com-load-file ()
615 (let ((filename (accept 'completable-pathname
616 :prompt "Load File")))
617 (load filename)))
618
619 (define-named-command com-beginning-of-buffer ()
620 (beginning-of-buffer (point (current-window))))
621
622 (define-named-command com-page-down ()
623 (let ((pane (current-window)))
624 (page-down pane)))
625
626 (define-named-command com-page-up ()
627 (let ((pane (current-window)))
628 (page-up pane)))
629
630 (define-named-command com-end-of-buffer ()
631 (end-of-buffer (point (current-window))))
632
633 (define-named-command com-back-to-indentation ()
634 (let ((point (point (current-window))))
635 (beginning-of-line point)
636 (loop until (end-of-line-p point)
637 while (whitespacep (object-after point))
638 do (incf (offset point)))))
639
640 (define-named-command com-goto-position ()
641 (setf (offset (point (current-window)))
642 (accept 'integer :prompt "Goto Position")))
643
644 (define-named-command com-goto-line ()
645 (loop with mark = (make-instance 'standard-right-sticky-mark
646 :buffer (buffer (current-window)))
647 do (end-of-line mark)
648 until (end-of-buffer-p mark)
649 repeat (accept 'integer :prompt "Goto Line")
650 do (incf (offset mark))
651 (end-of-line mark)
652 finally (beginning-of-line mark)
653 (setf (offset (point (current-window)))
654 (offset mark))))
655
656 (define-named-command com-browse-url ()
657 (accept 'url :prompt "Browse URL"))
658
659 (define-named-command com-set-mark ()
660 (let ((pane (current-window)))
661 (setf (mark pane) (clone-mark (point pane)))))
662
663 (define-named-command com-exchange-point-and-mark ()
664 (let ((pane (current-window)))
665 (psetf (offset (mark pane)) (offset (point pane))
666 (offset (point pane)) (offset (mark pane)))))
667
668 (define-named-command com-set-syntax ()
669 (let* ((pane (current-window))
670 (buffer (buffer pane)))
671 (setf (syntax buffer)
672 (make-instance (accept 'syntax :prompt "Set Syntax")))
673 (setf (offset (low-mark buffer)) 0
674 (offset (high-mark buffer)) (size buffer))))
675
676 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
677 ;;;
678 ;;; Commands for splitting windows
679
680 (defun replace-constellation (constellation additional-constellation vertical-p)
681 (let* ((parent (sheet-parent constellation))
682 (children (sheet-children parent))
683 (first (first children))
684 (second (second children)))
685 (assert (member constellation children))
686 (cond ((eq constellation first)
687 (sheet-disown-child parent constellation)
688 (let ((new (if vertical-p
689 (vertically () constellation additional-constellation)
690 (horizontally () constellation additional-constellation))))
691 (sheet-adopt-child parent new)
692 (reorder-sheets parent (list new second))))
693 (t
694 (sheet-disown-child parent constellation)
695 (let ((new (if vertical-p
696 (vertically () constellation additional-constellation)
697 (horizontally () constellation additional-constellation))))
698 (sheet-adopt-child parent new)
699 (reorder-sheets parent (list first new)))))))
700
701 (defun parent3 (sheet)
702 (sheet-parent (sheet-parent (sheet-parent sheet))))
703
704 (defun make-pane-constellation ()
705 "make a vbox containing a scroller pane as its first child and an
706 info pane as its second child. The scroller pane contains a viewport
707 which contains an extended pane. Return the vbox and the extended pane
708 as two values"
709 (let* ((extended-pane
710 (make-pane 'extended-pane
711 :width 900 :height 400
712 :name 'win
713 :incremental-redisplay t
714 :display-function 'display-win))
715 (vbox
716 (vertically ()
717 (scrolling () extended-pane)
718 (make-pane 'info-pane
719 :climacs-pane extended-pane
720 :width 900 :height 20
721 :max-height 20 :min-height 20
722 ::background +gray85+
723 :scroll-bars nil
724 :borders nil
725 :incremental-redisplay t
726 :display-function 'display-info))))
727 (values vbox extended-pane)))
728
729 (define-named-command com-split-window-vertically ()
730 (with-look-and-feel-realization
731 ((frame-manager *application-frame*) *application-frame*)
732 (multiple-value-bind (vbox new-pane) (make-pane-constellation)
733 (let* ((current-window (current-window))
734 (constellation-root (parent3 current-window)))
735 (setf (buffer new-pane) (buffer current-window))
736 (push new-pane (windows *application-frame*))
737 (replace-constellation constellation-root vbox t)
738 (full-redisplay current-window)
739 (full-redisplay new-pane)))))
740
741 (define-named-command com-split-window-horizontally ()
742 (with-look-and-feel-realization
743 ((frame-manager *application-frame*) *application-frame*)
744 (multiple-value-bind (vbox new-pane) (make-pane-constellation)
745 (let* ((current-window (current-window))
746 (constellation-root (parent3 current-window)))
747 (setf (buffer new-pane) (buffer current-window))
748 (push new-pane (windows *application-frame*))
749 (replace-constellation constellation-root vbox nil)
750 (full-redisplay current-window)
751 (full-redisplay new-pane)))))
752
753 (define-named-command com-other-window ()
754 (setf (windows *application-frame*)
755 (append (cdr (windows *application-frame*))
756 (list (car (windows *application-frame*))))))
757
758 (define-named-command com-delete-window ()
759 (unless (null (cdr (windows *application-frame*)))
760 (let* ((constellation (parent3 (current-window)))
761 (box (sheet-parent constellation))
762 (box-children (sheet-children box))
763 (other (if (eq constellation (first box-children))
764 (second box-children)
765 (first box-children)))
766 (parent (sheet-parent box))
767 (children (sheet-children parent))
768 (first (first children))
769 (second (second children)))
770 (pop (windows *application-frame*))
771 (sheet-disown-child box other)
772 (cond ((eq box first)
773 (sheet-disown-child parent box)
774 (sheet-adopt-child parent other)
775 (reorder-sheets parent (list other second)))
776 (t
777 (sheet-disown-child parent box)
778 (sheet-adopt-child parent other)
779 (reorder-sheets parent (list first other)))))))
780
781 ;;;;;;;;;;;;;;;;;;;;
782 ;; Kill ring commands
783
784 ;; Copies an element from a kill-ring to a buffer at the given offset
785 (define-named-command com-yank ()
786 (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
787
788 ;; Destructively cut a given buffer region into the kill-ring
789 (define-named-command com-cut-out ()
790 (multiple-value-bind (start end) (region-limits (current-window))
791 (kill-ring-standard-push *kill-ring* (region-to-sequence start end))
792 (delete-region (offset start) end)))
793
794 ;; Non destructively copies in buffer region to the kill ring
795 (define-named-command com-copy-out ()
796 (let ((pane (current-window)))
797 (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
798
799 (define-named-command com-rotate-yank ()
800 (let* ((pane (current-window))
801 (point (point pane))
802 (last-yank (kill-ring-yank *kill-ring*)))
803 (if (eq (previous-command pane)
804 'com-rotate-yank)
805 (progn
806 (delete-range point (* -1 (length last-yank)))
807 (rotate-yank-position *kill-ring*)))
808 (insert-sequence point (kill-ring-yank *kill-ring*))))
809
810 (define-named-command com-resize-kill-ring ()
811 (let ((size (accept 'integer :prompt "New kill ring size")))
812 (setf (kill-ring-max-size *kill-ring*) size)))
813
814 (define-named-command com-search-forward ()
815 (search-forward (point (current-window))
816 (accept 'string :prompt "Search Forward")
817 :test (lambda (a b)
818 (and (characterp b) (char-equal a b)))))
819
820 (define-named-command com-search-backward ()
821 (search-backward (point (current-window))
822 (accept 'string :prompt "Search Backward")
823 :test (lambda (a b)
824 (and (characterp b) (char-equal a b)))))
825
826 (define-named-command com-dabbrev-expand ()
827 (let* ((win (current-window))
828 (point (point win)))
829 (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win
830 (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
831 (setf (offset dabbrev-expansion-mark)
832 (offset point))
833 (forward-word dabbrev-expansion-mark))
834 ((mark< dabbrev-expansion-mark point)
835 (backward-object dabbrev-expansion-mark))
836 (t (forward-object dabbrev-expansion-mark)))))
837 (unless (or (beginning-of-buffer-p point)
838 (not (constituentp (object-before point))))
839 (unless (and (eq (previous-command win) 'com-dabbrev-expand)
840 (not (null prefix-start-offset)))
841 (setf dabbrev-expansion-mark (clone-mark point))
842 (backward-word dabbrev-expansion-mark)
843 (setf prefix-start-offset (offset dabbrev-expansion-mark))
844 (setf original-prefix (region-to-sequence prefix-start-offset point))
845 (move))
846 (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
847 (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
848 (not (constituentp (object-before dabbrev-expansion-mark))))
849 (looking-at dabbrev-expansion-mark original-prefix)))
850 do (move))
851 (if (end-of-buffer-p dabbrev-expansion-mark)
852 (progn (delete-region prefix-start-offset point)
853 (insert-sequence point original-prefix)
854 (setf prefix-start-offset nil))
855 (progn (delete-region prefix-start-offset point)
856 (insert-sequence point
857 (let ((offset (offset dabbrev-expansion-mark)))
858 (prog2 (forward-word dabbrev-expansion-mark)
859 (region-to-sequence offset dabbrev-expansion-mark)
860 (setf (offset dabbrev-expansion-mark) offset))))
861 (move))))))))
862
863 (define-named-command com-beginning-of-paragraph ()
864 (let* ((pane (current-window))
865 (point (point pane))
866 (syntax (syntax (buffer pane))))
867 (beginning-of-paragraph point syntax)))
868
869 (define-named-command com-end-of-paragraph ()
870 (let* ((pane (current-window))
871 (point (point pane))
872 (syntax (syntax (buffer pane))))
873 (end-of-paragraph point syntax)))
874
875 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
876 ;;;
877 ;;; Global and dead-escape command tables
878
879 (make-command-table 'global-climacs-table :errorp nil)
880
881 (make-command-table 'dead-escape-climacs-table :errorp nil)
882
883 (add-menu-item-to-command-table 'global-climacs-table "dead-escape"
884 :menu 'dead-escape-climacs-table
885 :keystroke '(:escape))
886
887 (defun dead-escape-set-key (gesture command)
888 (add-command-to-command-table command 'dead-escape-climacs-table
889 :keystroke gesture :errorp nil))
890
891 (defun global-set-key (gesture command)
892 (add-command-to-command-table command 'global-climacs-table
893 :keystroke gesture :errorp nil)
894 (when (and
895 (listp gesture)
896 (find :meta gesture))
897 (dead-escape-set-key (remove :meta gesture) command)))
898
899 (loop for code from (char-code #\space) to (char-code #\~)
900 do (global-set-key (code-char code) 'com-self-insert))
901
902 (global-set-key #\newline 'com-self-insert)
903 (global-set-key #\tab 'com-indent-line)
904 (global-set-key '(#\j :control) 'com-newline-and-indent)
905 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
906 (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
907 (global-set-key '(#\a :control) 'com-beginning-of-line)
908 (global-set-key '(#\e :control) 'com-end-of-line)
909 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
910 (global-set-key '(#\p :control) 'com-previous-line)
911 (global-set-key '(#\l :control) 'com-full-redisplay)
912 (global-set-key '(#\n :control) 'com-next-line)
913 (global-set-key '(#\o :control) 'com-open-line)
914 (global-set-key '(#\k :control) 'com-kill-line)
915 (global-set-key '(#\t :control) 'com-transpose-objects)
916 (global-set-key '(#\Space :control) 'com-set-mark)
917 (global-set-key '(#\y :control) 'com-yank)
918 (global-set-key '(#\w :control) 'com-cut-out)
919 (global-set-key '(#\f :meta) 'com-forward-word)
920 (global-set-key '(#\b :meta) 'com-backward-word)
921 (global-set-key '(#\t :meta) 'com-transpose-words)
922 (global-set-key '(#\u :meta) 'com-upcase-word)
923 (global-set-key '(#\l :meta) 'com-downcase-word)
924 (global-set-key '(#\c :meta) 'com-capitalize-word)
925 (global-set-key '(#\x :meta) 'com-extended-command)
926 (global-set-key '(#\y :meta) 'com-rotate-yank)
927 (global-set-key '(#\w :meta) 'com-copy-out)
928 (global-set-key '(#\v :control) 'com-page-down)
929 (global-set-key '(#\v :meta) 'com-page-up)
930 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
931 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
932 (global-set-key '(#\m :meta) 'com-back-to-indentation)
933 (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
934 (global-set-key '(#\d :meta) 'com-delete-word)
935 (global-set-key '(#\Backspace :meta) 'com-backward-delete-word)
936 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
937 (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph)
938 (global-set-key '(#\e :control :meta) 'com-end-of-paragraph)
939
940 (global-set-key '(:up) 'com-previous-line)
941 (global-set-key '(:down) 'com-next-line)
942 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
943 (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
944 (global-set-key '(:left :control) 'com-backward-word)
945 (global-set-key '(:right :control) 'com-forward-word)
946 (global-set-key '(:home) 'com-beginning-of-line)
947 (global-set-key '(:end) 'com-end-of-line)
948 (global-set-key '(:prior) 'com-page-up)
949 (global-set-key '(:next) 'com-page-down)
950 (global-set-key '(:home :control) 'com-beginning-of-buffer)
951 (global-set-key '(:end :control) 'com-end-of-buffer)
952 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
953 (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
954
955 (global-set-key '(:insert) 'com-toggle-overwrite-mode)
956
957 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
958 ;;;
959 ;;; C-x command table
960
961 (make-command-table 'c-x-climacs-table :errorp nil)
962
963 (add-menu-item-to-command-table 'global-climacs-table "C-x"
964 :menu 'c-x-climacs-table
965 :keystroke '(#\x :control))
966
967 (defun c-x-set-key (gesture command)
968 (add-command-to-command-table command 'c-x-climacs-table
969 :keystroke gesture :errorp nil))
970
971 (c-x-set-key '(#\0) 'com-delete-window)
972 (c-x-set-key '(#\2) 'com-split-window-vertically)
973 (c-x-set-key '(#\3) 'com-split-window-horizontally)
974 (c-x-set-key '(#\b) 'com-switch-to-buffer)
975 (c-x-set-key '(#\c :control) 'com-quit)
976 (c-x-set-key '(#\f :control) 'com-find-file)
977 (c-x-set-key '(#\l :control) 'com-load-file)
978 (c-x-set-key '(#\o) 'com-other-window)
979 (c-x-set-key '(#\s :control) 'com-save-buffer)
980 (c-x-set-key '(#\t :control) 'com-transpose-lines)
981 (c-x-set-key '(#\w :control) 'com-write-buffer)
982 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
983
984 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
985 ;;;
986 ;;; Some Unicode stuff
987
988 (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
989 (insert-object (point (current-window)) (code-char code)))
990
991 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
992 ;;;
993 ;;; Dead-acute command table
994
995 (make-command-table 'dead-acute-climacs-table :errorp nil)
996
997 (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
998 :menu 'dead-acute-climacs-table
999 :keystroke '(:dead--acute))
1000
1001 (defun dead-acute-set-key (gesture command)
1002 (add-command-to-command-table command 'dead-acute-climacs-table
1003 :keystroke gesture :errorp nil))
1004
1005 (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
1006 (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
1007 (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
1008 (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
1009 (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
1010 (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
1011 (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
1012 (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
1013 (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
1014 (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
1015 (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
1016 (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
1017 (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
1018 (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
1019 (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
1020 (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
1021 (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
1022 (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
1023 (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
1024 (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
1025
1026 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
1027
1028 (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
1029 :menu 'dead-acute-dead-accute-climacs-table
1030 :keystroke '(:dead--acute))
1031
1032 (defun dead-acute-dead-accute-set-key (gesture command)
1033 (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
1034 :keystroke gesture :errorp nil))
1035
1036 (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
1037 (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
1038 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1039 ;;;
1040 ;;; Dead-grave command table
1041
1042 (make-command-table 'dead-grave-climacs-table :errorp nil)
1043
1044 (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
1045 :menu 'dead-grave-climacs-table
1046 :keystroke '(:dead--grave))
1047
1048 (defun dead-grave-set-key (gesture command)
1049 (add-command-to-command-table command 'dead-grave-climacs-table
1050 :keystroke gesture :errorp nil))
1051
1052 (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
1053 (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
1054 (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
1055 (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
1056 (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
1057 (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
1058 (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
1059 (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
1060 (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
1061 (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
1062 (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
1063
1064 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1065 ;;;
1066 ;;; Dead-diaeresis command table
1067
1068 (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
1069
1070 (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
1071 :menu 'dead-diaeresis-climacs-table
1072 :keystroke '(:dead--diaeresis :shift))
1073
1074 (defun dead-diaeresis-set-key (gesture command)
1075 (add-command-to-command-table command 'dead-diaeresis-climacs-table
1076 :keystroke gesture :errorp nil))
1077
1078 (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
1079 (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
1080 (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
1081 (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
1082 (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
1083 (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
1084 (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
1085 (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
1086 (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
1087 (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
1088 (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
1089 (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
1090
1091 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1092 ;;;
1093 ;;; Dead-tilde command table
1094
1095 (make-command-table 'dead-tilde-climacs-table :errorp nil)
1096
1097 (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
1098 :menu 'dead-tilde-climacs-table
1099 :keystroke '(:dead--tilde :shift))
1100
1101 (defun dead-tilde-set-key (gesture command)
1102 (add-command-to-command-table command 'dead-tilde-climacs-table
1103 :keystroke gesture :errorp nil))
1104
1105 (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
1106 (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
1107 (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
1108 (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
1109 (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
1110 (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
1111 (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
1112 (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
1113 (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
1114 (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
1115 (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
1116
1117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1118 ;;;
1119 ;;; Dead-circumflex command table
1120
1121 (make-command-table 'dead-circumflex-climacs-table :errorp nil)
1122
1123 (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
1124 :menu 'dead-circumflex-climacs-table
1125 :keystroke '(:dead--circumflex :shift))
1126
1127 (defun dead-circumflex-set-key (gesture command)
1128 (add-command-to-command-table command 'dead-circumflex-climacs-table
1129 :keystroke gesture :errorp nil))
1130
1131 (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
1132 (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
1133 (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
1134 (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
1135 (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
1136 (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
1137 (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
1138 (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
1139 (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
1140 (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
1141 (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))

  ViewVC Help
Powered by ViewVC 1.1.5