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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5