/[gtk-cffi]/cl-emacs/keymap.lisp
ViewVC logotype

Contents of /cl-emacs/keymap.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sun May 13 16:20:49 2012 UTC (23 months ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +8 -2 lines
Minor fixes
1 (in-package :emacs)
2
3 (defparameter *entered-sequence* nil)
4 (defvar *global-keymap* nil)
5
6 (let (keymap)
7 (defun gdk-keymap ()
8 (unless keymap
9 (setf keymap (make-instance 'keymap)))
10 keymap))
11
12 (defun base-keycode (key)
13 (let ((keys (entries-for-keyval (gdk-keymap) key)))
14 (unless keys
15 (warn "No keycode. Bad key description ~a" key)
16 (return-from base-keycode nil))
17
18 (let ((filtered (delete-if-not (compose (curry #'eql 0) #'group) keys)))
19 (unless (= (length filtered) 1)
20 (warn "No unique latin keycode for ~a" key)
21 (return-from base-keycode nil))
22 (keycode (aref filtered 0)))))
23
24 (defun base-keyval (keycode)
25 (multiple-value-bind (keys keyvals)
26 (entries-for-keycode (gdk-keymap) keycode)
27 (iter
28 (for key in-vector keys)
29 (for keyval in-vector keyvals)
30 (when (and (zerop (group key)) (zerop (level key)))
31 (return-from base-keyval keyval)))))
32
33 (defmacro current-global-map ()
34 '*global-keymap*)
35
36 (defun symbol-name< (x y)
37 (string< (symbol-name x)
38 (symbol-name y)))
39
40 (defun %define-key (keymap key-seq binding)
41 "KEY-SEQ is a string in format C-x or C-Return or M-period.
42 Or S-M-period = M-> from emacs. Keys are for latin keymap.
43 Key names from X Window"
44 (let* ((new-key
45 (mapcar
46 (lambda (key)
47 (let (flags)
48 (macrolet
49 ((find-prefix (prefix flag)
50 `(when (and (> (length key) 1)
51 (string= (subseq key 0 2) ,prefix))
52 (setf key (subseq key 2))
53 (push ,flag flags)
54 (setf changed t))))
55 (do ((changed t nil)) ((not changed))
56 (find-prefix "C-" :control)
57 (find-prefix "M-" :mod1)
58 (find-prefix "S-" :shift)))
59 (list (base-keycode key) (sort flags #'symbol-name<))))
60
61 (delete-if (curry #'string= "")
62 (split-sequence:split-sequence #\Space key-seq))))
63 (try-find (assoc new-key keymap :test #'equal)))
64 (if binding
65 (if try-find
66 (setf (cdr try-find) binding)
67 (push (cons new-key binding) keymap))
68 (when try-find
69 (setf keymap (delete new-key keymap :test #'equal :key #'car))))
70 keymap))
71
72 (defmacro define-key (keymap key-seq binding)
73 "KEY-SEQ is a string in format C-x or C-Return or M-period.
74 Or S-M-period = M-> from emacs. Keys are for latin keymap.
75 Key names from X Window"
76 `(setf ,keymap (%define-key ,keymap ,key-seq ,binding)))
77
78 (defun seq-processed (seq)
79 "If found -- run, return t. if no partial found, return t, both means
80 sequence processed"
81 (let ((res t))
82 (mapc (lambda (x)
83 (let ((l (length seq)) (lx (length (car x))))
84 (cond
85 ((eql l lx)
86 (when (equal (car x) seq)
87 (progn (funcall (cdr x)) (return-from seq-processed t))))
88 ((> lx l)
89 (if (equal (subseq (car x) 0 l) seq)
90 (setf res nil))))))
91 *global-keymap*)
92 res))
93
94
95 (defun global-set-key (key-seq binding)
96 (define-key (current-global-map) key-seq binding))
97
98 (defun keyseq->string (seq)
99 (with-output-to-string (s)
100 (mapc (lambda (x)
101 (destructuring-bind (key flags) x
102 (when (member :control flags) (princ "C-" s))
103 (when (member :mod1 flags) (princ "M-" s))
104 (when (member :shift flags) (princ "S-" s))
105 (princ (keyval-name (base-keyval key)) s)
106 (princ "-" s)))
107 seq)))

  ViewVC Help
Powered by ViewVC 1.1.5