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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5