/[mcclim]/mcclim/dead-keys.lisp
ViewVC logotype

Contents of /mcclim/dead-keys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Thu May 1 21:45:23 2008 UTC (5 years, 11 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +4 -0 lines
Fix compile dependencies.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2008 by
4 ;;; Troels Henriksen (athas@sigkill.dk)
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 ;;; Define various dead keys - perhaps this should be more
22 ;;; backend-agnostic? Bah...
23
24 (in-package :clim-internals)
25
26 (defvar *dead-key-table* (make-hash-table :test 'equal)
27 "A hash table mapping keyboard event names and characters to
28 either a similar hash table or characters.")
29
30 (defun set-dead-key-combination (character gestures table)
31 "Set `gestures' to result in `character' in the hash table
32 `table' (see `*dead-key-table*' for the format of the hash
33 table)."
34 (assert (not (null gestures)))
35 (if (null (rest gestures))
36 ;; Just add it directly to this table.
37 (setf (gethash (first gestures) table) character)
38 ;; Ensure that the subtable exists.
39 (let ((new-table (setf (gethash (first gestures) table)
40 (gethash (first gestures) table
41 (make-hash-table :test 'equal)))))
42 (set-dead-key-combination character (rest gestures) new-table))))
43
44 (defmacro define-dead-key-combination (character (&rest gestures))
45 "Define a dead key combination that results in `character' when
46 `gestures' (either characters or key names) is entered."
47 (assert (>= (length gestures) 2))
48 `(set-dead-key-combination ,character ',gestures *dead-key-table*))
49
50 (define-dead-key-combination (code-char 193) (:dead-acute #\a))
51 (define-dead-key-combination (code-char 201) (:dead-acute #\e))
52 (define-dead-key-combination (code-char 205) (:dead-acute #\i))
53 (define-dead-key-combination (code-char 211) (:dead-acute #\o))
54 (define-dead-key-combination (code-char 218) (:dead-acute #\u))
55 (define-dead-key-combination (code-char 221) (:dead-acute #\y))
56 (define-dead-key-combination (code-char 225) (:dead-acute #\a))
57 (define-dead-key-combination (code-char 233) (:dead-acute #\e))
58 (define-dead-key-combination (code-char 237) (:dead-acute #\i))
59 (define-dead-key-combination (code-char 243) (:dead-acute #\o))
60 (define-dead-key-combination (code-char 250) (:dead-acute #\u))
61 (define-dead-key-combination (code-char 253) (:dead-acute #\y))
62 (define-dead-key-combination (code-char 199) (:dead-acute #\c))
63 (define-dead-key-combination (code-char 231) (:dead-acute #\c))
64 (define-dead-key-combination (code-char 215) (:dead-acute #\x))
65 (define-dead-key-combination (code-char 247) (:dead-acute #\-))
66 (define-dead-key-combination (code-char 222) (:dead-acute #\t))
67 (define-dead-key-combination (code-char 254) (:dead-acute #\t))
68 (define-dead-key-combination (code-char 223) (:dead-acute #\s))
69 (define-dead-key-combination (code-char 39) (:dead-acute #\space))
70 (define-dead-key-combination (code-char 197) (:dead-acute :dead-acute #\a))
71 (define-dead-key-combination (code-char 229) (:dead-acute :dead-acute #\a))
72 (define-dead-key-combination (code-char 192) (:dead-grave #\a))
73 (define-dead-key-combination (code-char 200) (:dead-grave #\e))
74 (define-dead-key-combination (code-char 204) (:dead-grave #\i))
75 (define-dead-key-combination (code-char 210) (:dead-grave #\o))
76 (define-dead-key-combination (code-char 217) (:dead-grave #\u))
77 (define-dead-key-combination (code-char 224) (:dead-grave #\a))
78 (define-dead-key-combination (code-char 232) (:dead-grave #\e))
79 (define-dead-key-combination (code-char 236) (:dead-grave #\i))
80 (define-dead-key-combination (code-char 242) (:dead-grave #\o))
81 (define-dead-key-combination (code-char 249) (:dead-grave #\u))
82 (define-dead-key-combination (code-char 96) (:dead-grave #\space))
83 (define-dead-key-combination (code-char 96) (:dead-grave :dead-grave))
84 (define-dead-key-combination (code-char 196) (:dead-diaeresis #\a))
85 (define-dead-key-combination (code-char 203) (:dead-diaeresis #\e))
86 (define-dead-key-combination (code-char 207) (:dead-diaeresis #\i))
87 (define-dead-key-combination (code-char 214) (:dead-diaeresis #\o))
88 (define-dead-key-combination (code-char 220) (:dead-diaeresis #\u))
89 (define-dead-key-combination (code-char 228) (:dead-diaeresis #\a))
90 (define-dead-key-combination (code-char 235) (:dead-diaeresis #\e))
91 (define-dead-key-combination (code-char 239) (:dead-diaeresis #\i))
92 (define-dead-key-combination (code-char 246) (:dead-diaeresis #\o))
93 (define-dead-key-combination (code-char 252) (:dead-diaeresis #\u))
94 (define-dead-key-combination (code-char 255) (:dead-diaeresis #\y))
95 (define-dead-key-combination (code-char 168) (:dead-diaeresis #\space))
96 (define-dead-key-combination (code-char 168) (:dead-diaeresis :dead-diaeresis))
97 (define-dead-key-combination (code-char 195) (:dead-tilde #\a))
98 (define-dead-key-combination (code-char 209) (:dead-tilde #\n))
99 (define-dead-key-combination (code-char 227) (:dead-tilde #\a))
100 (define-dead-key-combination (code-char 241) (:dead-tilde #\n))
101 (define-dead-key-combination (code-char 198) (:dead-tilde #\e))
102 (define-dead-key-combination (code-char 230) (:dead-tilde #\e))
103 (define-dead-key-combination (code-char 208) (:dead-tilde #\d))
104 (define-dead-key-combination (code-char 240) (:dead-tilde #\d))
105 (define-dead-key-combination (code-char 245) (:dead-tilde #\o))
106 (define-dead-key-combination (code-char 126) (:dead-tilde #\space))
107 (define-dead-key-combination (code-char 126) (:dead-tilde :dead-tilde))
108 (define-dead-key-combination (code-char 194) (:dead-circumflex #\a))
109 (define-dead-key-combination (code-char 202) (:dead-circumflex #\e))
110 (define-dead-key-combination (code-char 206) (:dead-circumflex #\i))
111 (define-dead-key-combination (code-char 212) (:dead-circumflex #\o))
112 (define-dead-key-combination (code-char 219) (:dead-circumflex #\u))
113 (define-dead-key-combination (code-char 226) (:dead-circumflex #\a))
114 (define-dead-key-combination (code-char 234) (:dead-circumflex #\e))
115 (define-dead-key-combination (code-char 238) (:dead-circumflex #\i))
116 (define-dead-key-combination (code-char 244) (:dead-circumflex #\o))
117 (define-dead-key-combination (code-char 251) (:dead-circumflex #\u))
118 (define-dead-key-combination (code-char 94) (:dead-circumflex #\space))
119 (define-dead-key-combination (code-char 94) (:dead-circumflex :dead-circumflex))
120
121 (defmacro merging-dead-keys ((gesture state) &body body)
122 "Accumulate dead keys and subsequent characters. `Gesture'
123 should be a symbol bound to either a gesture or an input
124 event. `Body' will be evaluated either with the `gesture' binding
125 unchanged, or with `gesture' bound to the result of merging
126 preceding dead keys. `State' must be a place, initially NIL, that
127 will contain the state of dead-key handling, enabling
128 asynchronous use of the macro."
129 `(flet ((invoke-body (,gesture)
130 ,@body))
131 (when (null ,state)
132 (setf ,state *dead-key-table*))
133 (if (typep ,gesture '(or keyboard-event character))
134 (let ((value (gethash (if (characterp ,gesture)
135 ,gesture
136 (keyboard-event-key-name ,gesture))
137 ,state)))
138 (etypecase value
139 (null
140 (cond ((eq ,state *dead-key-table*)
141 (invoke-body ,gesture))
142 ((or (and (typep ,gesture 'keyboard-event)
143 (keyboard-event-character ,gesture))
144 (characterp ,gesture))
145 (setf ,state *dead-key-table*))))
146 (character
147 (setf ,state *dead-key-table*)
148 (invoke-body value))
149 (hash-table
150 (setf ,state value)
151 (invoke-body value))))
152 (progn (setf ,state *dead-key-table*)
153 (invoke-body ,gesture)))))

  ViewVC Help
Powered by ViewVC 1.1.5