1: \ ekey etc.
2:
3: \ Copyright (C) 1999,2002,2003,2004,2005 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: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
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: \ most of the keys are also in pfe, except:
39: \ k-insert, k-delete, k11, k12, s-k11, s-k12
40:
41: keycode k-left ( -- u ) \ gforth
42: keycode k-right ( -- u ) \ gforth
43: keycode k-up ( -- u ) \ gforth
44: keycode k-down ( -- u ) \ gforth
45: keycode k-home ( -- u ) \ gforth
46: \G aka Pos1
47: keycode k-end ( -- u ) \ gforth
48: keycode k-prior ( -- u ) \ gforth
49: \G aka PgUp
50: keycode k-next ( -- u ) \ gforth
51: \G aka PgDn
52: keycode k-insert ( -- u ) \ gforth
53: 127 constant k-delete ( -- u ) \ gforth
54: \ not an escape sequence on my xterm, so use ASCII code
55:
56: \ function/keypad keys
57: keycode k1 ( -- u ) \ gforth
58: keycode k2 ( -- u ) \ gforth
59: keycode k3 ( -- u ) \ gforth
60: keycode k4 ( -- u ) \ gforth
61: keycode k5 ( -- u ) \ gforth
62: keycode k6 ( -- u ) \ gforth
63: keycode k7 ( -- u ) \ gforth
64: keycode k8 ( -- u ) \ gforth
65: keycode k9 ( -- u ) \ gforth
66: keycode k10 ( -- u ) \ gforth
67: keycode k11 ( -- u ) \ gforth
68: keycode k12 ( -- u ) \ gforth
69: \ shifted fuinction keys (don't work in xterm (same as unshifted, but
70: \ s-k1..s-k8 work in the Linux console)
71: keycode s-k1 ( -- u ) \ gforth
72: keycode s-k2 ( -- u ) \ gforth
73: keycode s-k3 ( -- u ) \ gforth
74: keycode s-k4 ( -- u ) \ gforth
75: keycode s-k5 ( -- u ) \ gforth
76: keycode s-k6 ( -- u ) \ gforth
77: keycode s-k7 ( -- u ) \ gforth
78: keycode s-k8 ( -- u ) \ gforth
79: keycode s-k9 ( -- u ) \ gforth
80: keycode s-k10 ( -- u ) \ gforth
81: keycode s-k11 ( -- u ) \ gforth
82: keycode s-k12 ( -- u ) \ gforth
83:
84: \ helper word
85: \ print a key sequence:
86: \ : key-sequence ( -- )
87: \ key begin
88: \ cr dup . emit
89: \ key? while
90: \ key
91: \ repeat ;
92:
93: create key-buffer 8 chars allot
94: 2variable key-buffered key-buffer 0 key-buffered 2!
95:
96: : char-append-buffer ( c addr -- )
97: tuck 2@ chars + c!
98: dup 2@ 1+ rot 2! ;
99:
100: :noname ( -- c )
101: \ buffered key
102: key-buffered 2@ dup if
103: 1- 2dup key-buffered 2!
104: chars + c@
105: else
106: 2drop defers key
107: then ;
108: is key
109:
110: : unkey ( c -- )
111: key-buffered char-append-buffer ;
112:
113: : unkeys ( addr u -- )
114: -1 swap 1- -do
115: dup i chars + c@ unkey
116: 1 -loop
117: drop ;
118:
119: :noname ( -- flag )
120: key-buffered 2@ nip 0<> defers key? or ;
121: is key?
122:
123: table constant esc-sequences \ and prefixes
124:
125: create ekey-buffer 8 chars allot
126: 2variable ekey-buffered
127:
128: [IFUNDEF] #esc 27 Constant #esc [THEN]
129:
130: : esc-prefix ( -- u )
131: key? if
132: key ekey-buffered char-append-buffer
133: ekey-buffered 2@ esc-sequences search-wordlist
134: if
135: execute exit
136: endif
137: endif
138: ekey-buffered 2@ unkeys #esc ;
139:
140: : esc-sequence ( xt addr u -- ; name execution: -- u ) recursive
141: \ define key "name" and all prefixes
142: 2dup 1- dup
143: if
144: 2dup esc-sequences search-wordlist
145: if
146: drop 2drop
147: else
148: ['] esc-prefix -rot esc-sequence
149: then
150: else
151: 2drop
152: then ( xt addr u )
153: nextname alias ;
154:
155: \ nac02dec1999 exclude the escape sequences if we are using crossdoc.fs to generate
156: \ a documentation file. Do this because key sequences [ and OR here clash with
157: \ standard names and so prevent them appearing in the documentation.
158: [IFUNDEF] put-doc-entry
159: get-current esc-sequences set-current
160:
161: \ esc sequences (derived by using key-sequence in an xterm)
162:
163: ' k-left s" [D" esc-sequence
164: ' k-right s" [C" esc-sequence
165: ' k-up s" [A" esc-sequence
166: ' k-down s" [B" esc-sequence
167: ' k-home s" [H" esc-sequence
168: ' k-end s" [F" esc-sequence
169: ' k-prior s" [5~" esc-sequence
170: ' k-next s" [6~" esc-sequence
171: ' k-insert s" [2~" esc-sequence
172:
173: ' k1 s" OP" esc-sequence
174: ' k2 s" OQ" esc-sequence
175: ' k3 s" OR" esc-sequence
176: ' k4 s" OS" esc-sequence
177: ' k5 s" [15~" esc-sequence
178: ' k6 s" [17~" esc-sequence
179: ' k7 s" [18~" esc-sequence
180: ' k8 s" [19~" esc-sequence
181: ' k9 s" [20~" esc-sequence
182: ' k10 s" [21~" esc-sequence
183: ' k11 s" [23~" esc-sequence
184: ' k12 s" [24~" esc-sequence
185:
186: \ esc sequences from Linux console:
187:
188: ' k1 s" [[A" esc-sequence
189: ' k2 s" [[B" esc-sequence
190: ' k3 s" [[C" esc-sequence
191: ' k4 s" [[D" esc-sequence
192: ' k5 s" [[E" esc-sequence
193: ' k-delete s" [3~" esc-sequence
194: ' k-home s" [1~" esc-sequence
195: ' k-end s" [4~" esc-sequence
196:
197: ' s-k1 s" [25~" esc-sequence
198: ' s-k2 s" [26~" esc-sequence
199: ' s-k3 s" [28~" esc-sequence
200: ' s-k4 s" [29~" esc-sequence
201: ' s-k5 s" [31~" esc-sequence
202: ' s-k6 s" [32~" esc-sequence
203: ' s-k7 s" [33~" esc-sequence
204: ' s-k8 s" [34~" esc-sequence
205:
206: set-current
207: [ENDIF]
208:
209: : clear-ekey-buffer ( -- )
210: ekey-buffer 0 ekey-buffered 2! ;
211:
212: : ekey ( -- u ) \ facility-ext e-key
213: \G Receive a keyboard event @var{u} (encoding implementation-defined).
214: key dup #esc =
215: if
216: drop clear-ekey-buffer
217: esc-prefix
218: then ;
219:
220: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
221: \G Convert keyboard event @var{u} into character @code{c} if possible.
222: dup k-left u< ; \ k-left must be first!
223:
224: ' key? alias ekey? ( -- flag ) \ facility-ext e-key-question
225: \G True if a keyboard event is available.
226:
227: \ : esc? ( -- flag ) recursive
228: \ key? 0=
229: \ if
230: \ false exit
231: \ then
232: \ key ekey-buffered char-append-buffer
233: \ ekey-buffered 2@ esc-sequences search-wordlist
234: \ if
235: \ ['] esc-prefix =
236: \ if
237: \ esc? exit
238: \ then
239: \ then
240: \ true ;
241:
242: \ : ekey? ( -- flag ) \ facility-ext e-key-question
243: \ \G Return @code{true} if a keyboard event is available (use
244: \ \G @code{ekey} to receive the event), @code{false} otherwise.
245: \ key?
246: \ if
247: \ key dup #esc =
248: \ if
249: \ clear-ekey-buffer esc?
250: \ ekey-buffered 2@ unkeys
251: \ else
252: \ true
253: \ then
254: \ swap unkey
255: \ else
256: \ false
257: \ then ;
258:
259: \ : test-ekey?
260: \ begin
261: \ begin
262: \ begin
263: \ key? until
264: \ ekey? until
265: \ .s ekey .s drop
266: \ again ;
267: \ test-ekey?
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ekey.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth