[gforth] / gforth / ekey.fs  

gforth: gforth/ekey.fs

1 : anton 1.1 \ ekey etc.
2 :    
3 :     \ Copyright (C) 1999 Free Software Foundation, Inc.
4 :    
5 :     \ This file is part of Gforth.
6 :    
7 :     \ Gforth is free software; you can redistribute it and/or
8 :     \ modify it under the terms of the GNU General Public License
9 :     \ as published by the Free Software Foundation; either version 2
10 :     \ of the License, or (at your option) any later version.
11 :    
12 :     \ This program is distributed in the hope that it will be useful,
13 :     \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14 :     \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 :     \ GNU General Public License for more details.
16 :    
17 :     \ You should have received a copy of the GNU General Public License
18 :     \ along with this program; if not, write to the Free Software
19 : anton 1.3 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20 : anton 1.1
21 :    
22 :     \ this implementation of EKEY just translates VT100/ANSI escape
23 :     \ sequences to ekeys.
24 :    
25 :     \ Caveats: It also translates the sequences if they were not generated
26 :     \ by pressing the key; moreover, it waits until a complete sequence or
27 :     \ an invalid prefix to a sequence has arrived before reporting true in
28 :     \ EKEY? and before completing EKEY. One way to fix this would be to
29 :     \ use timeouts when waiting for the next key; however, this may lead
30 :     \ to situations in slow networks where single events result in several
31 :     \ EKEYs, which appears less desirable to me.
32 :    
33 :     \ The keycode names are compatible with pfe-0.9.14
34 :    
35 :     : keycode ( "name" -- ; name execution: -- u )
36 :     create ;
37 :    
38 :     keycode k-left
39 :     keycode k-right
40 :     keycode k-up
41 :     keycode k-down
42 :     keycode k-home
43 :     keycode k-end
44 : anton 1.4 keycode k-prior \ note: captured by xterm
45 :     keycode k-next \ note: captured by xterm
46 : anton 1.1 keycode k-insert \ not in pfe
47 : anton 1.4 127 constant k-delete \ not an escape sequence on my xterm, so use ASCII code
48 : anton 1.1 \ function/keypad keys
49 :     keycode k1
50 :     keycode k2
51 :     keycode k3
52 :     keycode k4
53 :     keycode k5
54 :     keycode k6
55 :     keycode k7
56 :     keycode k8
57 :     keycode k9
58 :     keycode k10
59 :     keycode k11 \ not in pfe
60 :     keycode k12 \ not in pfe
61 :     \ shifted function/keypad keys have the same key sequences (in xterm)
62 :     \ and pfe gives the same keycodes; so what are these keycodes good for?
63 :     \ keycode s-k1
64 :     \ keycode s-k2
65 :     \ keycode s-k3
66 :     \ keycode s-k4
67 :     \ keycode s-k5
68 :     \ keycode s-k6
69 :     \ keycode s-k7
70 :     \ keycode s-k8
71 :     \ keycode s-k9
72 :     \ keycode s-k10
73 :     \ keycode s-k11 \ not in pfe
74 :     \ keycode s-k12 \ not in pfe
75 :    
76 :     \ helper word
77 :     \ print a key sequence:
78 :     \ : key-sequence ( -- )
79 :     \ key begin
80 :     \ cr dup . emit
81 :     \ key? while
82 :     \ key
83 :     \ repeat ;
84 :    
85 :     create key-buffer 8 chars allot
86 :     2variable key-buffered key-buffer 0 key-buffered 2!
87 :    
88 :     : char-append-buffer ( c addr -- )
89 :     tuck 2@ chars + c!
90 :     dup 2@ 1+ rot 2! ;
91 :    
92 :     :noname ( -- c )
93 :     \ buffered key
94 :     key-buffered 2@ dup if
95 :     1- 2dup key-buffered 2!
96 :     chars + c@
97 :     else
98 :     2drop defers key
99 :     then ;
100 :     is key
101 :    
102 :     : unkey ( c -- )
103 :     key-buffered char-append-buffer ;
104 :    
105 :     : unkeys ( addr u -- )
106 :     -1 swap 1- -do
107 :     dup i chars + c@ unkey
108 :     1 -loop
109 :     drop ;
110 :    
111 :     :noname ( -- flag )
112 :     key-buffered 2@ nip 0<> defers key? or ;
113 :     is key?
114 :    
115 :     table constant esc-sequences \ and prefixes
116 :    
117 :     create ekey-buffer 8 chars allot
118 :     2variable ekey-buffered
119 :    
120 :     27 constant #esc
121 :    
122 :     : esc-prefix ( -- u )
123 :     key ekey-buffered char-append-buffer
124 :     ekey-buffered 2@ esc-sequences search-wordlist
125 :     if
126 :     execute exit
127 :     else
128 :     ekey-buffered 2@ unkeys #esc
129 :     then ;
130 :    
131 :     : esc-sequence ( xt addr u -- ; name execution: -- u ) recursive
132 :     \ define key "name" and all prefixes
133 :     2dup 1- dup
134 :     if
135 :     2dup esc-sequences search-wordlist
136 :     if
137 :     drop 2drop
138 :     else
139 :     ['] esc-prefix -rot esc-sequence
140 :     then
141 :     else
142 :     2drop
143 :     then ( xt addr u )
144 :     nextname alias ;
145 :    
146 : crook 1.2 \ nac02dec1999 exclude the escape sequences if we are using crossdoc.fs to generate
147 :     \ a documentation file. Do this because key sequences [ and OR here clash with
148 :     \ standard names and so prevent them appearing in the documentation.
149 :     [IFUNDEF] put-doc-entry
150 : anton 1.1 get-current esc-sequences set-current
151 :    
152 :     \ esc sequences (derived by using key-sequence in an xterm)
153 :    
154 :     ' k-left s" [D" esc-sequence
155 :     ' k-right s" [C" esc-sequence
156 :     ' k-up s" [A" esc-sequence
157 :     ' k-down s" [B" esc-sequence
158 :     ' k-home s" [H" esc-sequence
159 :     ' k-end s" [F" esc-sequence
160 : anton 1.4 ' k-prior s" [5~" esc-sequence
161 :     ' k-next s" [6~" esc-sequence
162 : anton 1.1 ' k-insert s" [2~" esc-sequence
163 :    
164 :     ' k1 s" OP" esc-sequence
165 :     ' k2 s" OQ" esc-sequence
166 :     ' k3 s" OR" esc-sequence
167 :     ' k4 s" OS" esc-sequence
168 :     ' k5 s" [15~" esc-sequence
169 :     ' k6 s" [17~" esc-sequence
170 :     ' k7 s" [18~" esc-sequence
171 :     ' k8 s" [19~" esc-sequence
172 :     ' k9 s" [20~" esc-sequence
173 :     ' k10 s" [21~" esc-sequence
174 :     ' k11 s" [23~" esc-sequence
175 :     ' k12 s" [24~" esc-sequence
176 : anton 1.4
177 :     \ esc sequences from Linux console:
178 :    
179 :     ' k1 s" [[A" esc-sequence
180 :     ' k2 s" [[B" esc-sequence
181 :     ' k3 s" [[C" esc-sequence
182 :     ' k4 s" [[D" esc-sequence
183 :     ' k5 s" [[E" esc-sequence
184 :     ' k-delete s" [3~" esc-sequence
185 :     ' k-home s" [1~" esc-sequence
186 :     ' k-end s" [4~" esc-sequence
187 : anton 1.1
188 :     set-current
189 : crook 1.2 [ENDIF]
190 : anton 1.1
191 :     : clear-ekey-buffer ( -- )
192 :     ekey-buffer 0 ekey-buffered 2! ;
193 :    
194 : crook 1.2 : ekey ( -- u ) \ facility-ext e-key
195 : anton 1.1 key dup #esc =
196 :     if
197 :     drop clear-ekey-buffer
198 :     esc-prefix
199 :     then ;
200 :    
201 : crook 1.2 : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
202 : anton 1.1 dup 256 u< ;
203 :    
204 :     : esc? ( -- flag ) recursive
205 :     key? 0=
206 :     if
207 :     false exit
208 :     then
209 :     key ekey-buffered char-append-buffer
210 :     ekey-buffered 2@ esc-sequences search-wordlist
211 :     if
212 :     ['] esc-prefix =
213 :     if
214 :     esc? exit
215 :     then
216 :     then
217 :     true ;
218 :    
219 : crook 1.2 : ekey? ( -- flag ) \ facility-ext e-key-question
220 :     \G Return @code{true} if a keyboard event is available (use
221 :     \G @code{ekey} to receive the event), @code{false} otherwise.
222 : anton 1.1 key?
223 :     if
224 :     key dup #esc =
225 :     if
226 :     clear-ekey-buffer esc?
227 :     ekey-buffered 2@ unkeys
228 :     else
229 :     true
230 :     then
231 :     swap unkey
232 :     else
233 :     false
234 :     then ;
235 :    
236 :     \ : test-ekey?
237 :     \ begin
238 :     \ begin
239 :     \ begin
240 :     \ key? until
241 :     \ ekey? until
242 :     \ .s ekey .s drop
243 :     \ again ;
244 :     \ test-ekey?
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help