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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5