/[cmucl]/src/hemlock/keytran.lisp
ViewVC logotype

Contents of /src/hemlock/keytran.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +0 -2 lines
Fix headed boilerplate.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: extensions -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8     "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/keytran.lisp,v 1.3 1994/10/31 04:50:12 ram Rel $")
9     ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file contains a default character translation mechanism for X11
13     ;;; scan codes, keysyms, button codes, and modifier bits.
14     ;;;
15     ;;; Written by Bill Chiles.
16     ;;;
17    
18     (in-package "EXTENSIONS")
19    
20     (export '(define-keysym define-mouse-code define-keyboard-modifier
21     translate-character translate-mouse-character))
22    
23    
24    
25     ;;;; Keysym to character translation.
26    
27     ;;; Hemlock uses its own keysym to character translation since this is easier
28     ;;; and more versatile than the CLX design. Also, using CLX's mechanism is no
29     ;;; more portable than writing our own translation based on the X11 protocol
30     ;;; keysym specification.
31     ;;;
32     ;;; In the first table, nil indicates a non-event which is pertinent to
33     ;;; ignoring modifier keys being pressed prior to pressing a key to be
34     ;;; modified. In the second table, nil simply indicates that there is no
35     ;;; special shift translation for the keysym, and that the CLX shifted keysym
36     ;;; should be looked up as normal (see TRANSLATE-CHARACTER).
37     ;;;
38     ;;; This mapping is initialized with DEFINE-KEYSYM in Keytrandefs.Lisp
39     ;;;
40     (defvar *keysym-translations* (make-hash-table))
41     (defvar *shifted-keysym-translations* (make-hash-table))
42    
43     (defun define-keysym (keysym char &optional shifted-char)
44     "Defines a keysym for Hemlock's translation. If shifted-char is supplied,
45     it is a character to use when the :shift modifier is on for an incoming
46     keysym. If shifted-char is not supplied, and the :shift modifier is set,
47     then XLIB:KEYCODE->KEYSYM is called with an index of 1 instead of 0. If
48     a :lock modifier is set, it is treated as a caps-lock. See
49     DEFINE-KEYBOARD-MODIFIER."
50     (check-type char character)
51     (setf (gethash keysym *keysym-translations*) char)
52     (when shifted-char
53     (check-type shifted-char character)
54     (setf (gethash keysym *shifted-keysym-translations*) shifted-char))
55     t)
56    
57    
58     ;;; X modifier bits translation
59     ;;;
60     (defvar *modifier-translations* ())
61    
62     (defun define-keyboard-modifier (clx-mask modifier-name)
63     "Causes clx-mask to be interpreted as modifier-name which must be one of
64     :control, :meta, :super, :hyper, :shift, or :lock."
65     (let ((map (assoc clx-mask *modifier-translations*)))
66     (if map
67     (rplacd map modifier-name)
68     (push (cons clx-mask modifier-name) *modifier-translations*))))
69    
70     (define-keyboard-modifier (xlib:make-state-mask :control) :control)
71     (define-keyboard-modifier (xlib:make-state-mask :mod-1) :meta)
72     (define-keyboard-modifier (xlib:make-state-mask :shift) :shift)
73     (define-keyboard-modifier (xlib:make-state-mask :lock) :lock)
74    
75    
76     (defun translate-character (display scan-code bits)
77     "Translates scan-code and modifier bits to a Lisp character. The scan code
78     is first mapped to a keysym with index 0 for unshifted and index 1 for
79     shifted. If this keysym does not map to a character, and it is not a
80     modifier key (shift, ctrl, etc.), then an error is signaled. If the keysym
81     is a modifier key, then nil is returned. If we do have a character, and the
82     shift bit is off, and the lock bit is on, and the character is alphabetic,
83     then we get a new keysym with index 1, mapping it to a character. If this
84     does not result in a character, an error is signaled. If we have a
85     character, and the shift bit is on, then we look for a special shift mapping
86     for the original keysym. This allows for distinct characters for scan
87     codes that map to the same keysym, shifted or unshifted, (e.g., number pad
88     or arrow keys)."
89     (let ((dummy #\?)
90     shiftp lockp)
91     (dolist (ele *modifier-translations*)
92     (unless (zerop (logand (car ele) bits))
93     (case (cdr ele)
94     (:shift (setf shiftp t))
95     (:lock (setf lockp t))
96     (t (setf dummy (set-char-bit dummy (cdr ele) t))))))
97     (let* ((keysym (xlib:keycode->keysym display scan-code (if shiftp 1 0)))
98     (temp-char (gethash keysym *keysym-translations*)))
99     (cond ((not temp-char)
100     (if (<= 65505 keysym 65518) ;modifier keys.
101     nil
102     (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM."
103     keysym)))
104     ((and (not shiftp) lockp (alpha-char-p temp-char))
105     (let* ((keysym (xlib:keycode->keysym display scan-code 1))
106     (char (gethash keysym *keysym-translations*)))
107     (unless char
108     (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM."
109     keysym))
110     (make-char char (logior (char-bits char) (char-bits dummy)))))
111     (shiftp
112     (let ((char (gethash keysym *shifted-keysym-translations*)))
113     (if char
114     (make-char char (logior (char-bits char) (char-bits dummy)))
115     (make-char temp-char (logior (char-bits temp-char)
116     (char-bits dummy))))))
117     (t (make-char temp-char (logior (char-bits temp-char)
118     (char-bits dummy))))))))
119    
120    
121    
122     ;;;; Mouse to character translations.
123    
124     ;;; Mouse codes come from the server numbered one through five. This table is
125     ;;; indexed by the code to retrieve a list. The CAR is a cons of the char and
126     ;;; shifted char associated with a :button-press event. The CDR is a cons of
127     ;;; the char and shifted char associated with a :button-release event. Each
128     ;;; of these is potentially nil (not a cons at all).
129     ;;;
130     (defvar *mouse-translations* (make-array 6 :initial-element nil))
131     ;;;
132     (defmacro mouse-press-chars (ele) `(car ,ele))
133     (defmacro mouse-release-chars (ele) `(cadr ,ele))
134    
135     (defun define-mouse-code (button char shifted-char event-key)
136     "Causes X button code to be interpreted as char. Shift and Lock modifiers
137     associated with button map to shifted-char. For the same button code,
138     event-key may be :button-press or :button-release."
139     (check-type char character)
140     (check-type shifted-char character)
141     (check-type event-key (member :button-press :button-release))
142     (let ((stuff (svref *mouse-translations* button))
143     (trans (cons char shifted-char)))
144     (if stuff
145     (case event-key
146     (:button-press (setf (mouse-press-chars stuff) trans))
147     (:button-release (setf (mouse-release-chars stuff) trans)))
148     (case event-key
149     (:button-press
150     (setf (svref *mouse-translations* button) (list trans nil)))
151     (:button-release
152     (setf (svref *mouse-translations* button) (list nil trans))))))
153     t)
154    
155     (define-mouse-code 1 #\leftdown #\super-leftdown :button-press)
156     (define-mouse-code 1 #\leftup #\super-leftup :button-release)
157    
158     (define-mouse-code 2 #\middledown #\super-middledown :button-press)
159     (define-mouse-code 2 #\middleup #\super-middleup :button-release)
160    
161     (define-mouse-code 3 #\rightdown #\super-rightdown :button-press)
162     (define-mouse-code 3 #\rightup #\super-rightup :button-release)
163    
164     (defun translate-mouse-character (scan-code bits event-key)
165     "Translates X button code, scan-code, and modifier bits, bits, for event-key
166     (either :button-press or :button-release) to a Lisp character."
167     (let ((temp (svref *mouse-translations* scan-code)))
168     (unless temp (error "Unknown mouse button -- ~S." scan-code))
169     (let ((trans (ecase event-key
170     (:button-press (mouse-press-chars temp))
171     (:button-release (mouse-release-chars temp)))))
172     (unless trans (error "Undefined ~S characters for mouse button ~S."
173     event-key scan-code))
174     (let ((dummy #\?)
175     shiftp)
176     (dolist (ele *modifier-translations*)
177     (unless (zerop (logand (car ele) bits))
178     (let ((bit (cdr ele)))
179     (if (or (eq bit :shift) (eq bit :lock))
180     (setf shiftp t)
181     (setf dummy (set-char-bit dummy bit t))))))
182     (let ((char (if shiftp (cdr trans) (car trans))))
183     (make-char char (logior (char-bits char) (char-bits dummy))))))))

  ViewVC Help
Powered by ViewVC 1.1.5