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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5