Annotation of gforth/ekey.fs, revision 1.19
1.1 anton 1: \ ekey etc.
2:
1.18 anton 3: \ Copyright (C) 1999,2002,2003,2004,2005,2006,2007 Free Software Foundation, Inc.
1.1 anton 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
1.19 ! anton 9: \ as published by the Free Software Foundation, either version 3
1.1 anton 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
1.19 ! anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1 anton 19:
20:
21: \ this implementation of EKEY just translates VT100/ANSI escape
22: \ sequences to ekeys.
23:
24: \ Caveats: It also translates the sequences if they were not generated
25: \ by pressing the key; moreover, it waits until a complete sequence or
26: \ an invalid prefix to a sequence has arrived before reporting true in
27: \ EKEY? and before completing EKEY. One way to fix this would be to
28: \ use timeouts when waiting for the next key; however, this may lead
29: \ to situations in slow networks where single events result in several
30: \ EKEYs, which appears less desirable to me.
31:
32: \ The keycode names are compatible with pfe-0.9.14
33:
1.17 anton 34: : keycode ( u1 "name" -- u2 ; name execution: -- u )
35: dup constant 1+ ;
1.1 anton 36:
1.12 anton 37: \ most of the keys are also in pfe, except:
38: \ k-insert, k-delete, k11, k12, s-k11, s-k12
39:
1.17 anton 40: $40000000 constant k-shift-mask ( -- u ) \ X:ekeys
41: $20000000 constant k-ctrl-mask ( -- u ) \ X:ekeys
42: $10000000 constant k-alt-mask ( -- u ) \ X:ekeys
43:
44: $80000000
45: keycode k-left ( -- u ) \ X:ekeys
46: keycode k-right ( -- u ) \ X:ekeys
47: keycode k-up ( -- u ) \ X:ekeys
48: keycode k-down ( -- u ) \ X:ekeys
49: keycode k-home ( -- u ) \ X:ekeys
1.12 anton 50: \G aka Pos1
1.17 anton 51: keycode k-end ( -- u ) \ X:ekeys
52: keycode k-prior ( -- u ) \ X:ekeys
1.12 anton 53: \G aka PgUp
1.17 anton 54: keycode k-next ( -- u ) \ X:ekeys
1.12 anton 55: \G aka PgDn
1.17 anton 56: keycode k-insert ( -- u ) \ X:ekeys
57: keycode k-delete ( -- u ) \ X:ekeys
58: \ the DEL key on my xterm, not backspace
1.12 anton 59:
1.1 anton 60: \ function/keypad keys
1.17 anton 61: keycode k-f1 ( -- u ) \ X:ekeys
62: keycode k-f2 ( -- u ) \ X:ekeys
63: keycode k-f3 ( -- u ) \ X:ekeys
64: keycode k-f4 ( -- u ) \ X:ekeys
65: keycode k-f5 ( -- u ) \ X:ekeys
66: keycode k-f6 ( -- u ) \ X:ekeys
67: keycode k-f7 ( -- u ) \ X:ekeys
68: keycode k-f8 ( -- u ) \ X:ekeys
69: keycode k-f9 ( -- u ) \ X:ekeys
70: keycode k-f10 ( -- u ) \ X:ekeys
71: keycode k-f11 ( -- u ) \ X:ekeys
72: keycode k-f12 ( -- u ) \ X:ekeys
73: drop
74:
75: ' k-f1 alias k1 ( -- u ) \ gforth-obsolete
76: ' k-f2 alias k2 ( -- u ) \ gforth-obsolete
77: ' k-f3 alias k3 ( -- u ) \ gforth-obsolete
78: ' k-f4 alias k4 ( -- u ) \ gforth-obsolete
79: ' k-f5 alias k5 ( -- u ) \ gforth-obsolete
80: ' k-f6 alias k6 ( -- u ) \ gforth-obsolete
81: ' k-f7 alias k7 ( -- u ) \ gforth-obsolete
82: ' k-f8 alias k8 ( -- u ) \ gforth-obsolete
83: ' k-f9 alias k9 ( -- u ) \ gforth-obsolete
84: ' k-f10 alias k10 ( -- u ) \ gforth-obsolete
85: ' k-f11 alias k11 ( -- u ) \ gforth-obsolete
86: ' k-f12 alias k12 ( -- u ) \ gforth-obsolete
1.5 anton 87: \ shifted fuinction keys (don't work in xterm (same as unshifted, but
88: \ s-k1..s-k8 work in the Linux console)
1.17 anton 89: k-f1 k-shift-mask or constant s-k1 ( -- u ) \ gforth-obsolete
90: k-f2 k-shift-mask or constant s-k2 ( -- u ) \ gforth-obsolete
91: k-f3 k-shift-mask or constant s-k3 ( -- u ) \ gforth-obsolete
92: k-f4 k-shift-mask or constant s-k4 ( -- u ) \ gforth-obsolete
93: k-f5 k-shift-mask or constant s-k5 ( -- u ) \ gforth-obsolete
94: k-f6 k-shift-mask or constant s-k6 ( -- u ) \ gforth-obsolete
95: k-f7 k-shift-mask or constant s-k7 ( -- u ) \ gforth-obsolete
96: k-f8 k-shift-mask or constant s-k8 ( -- u ) \ gforth-obsolete
97: k-f9 k-shift-mask or constant s-k9 ( -- u ) \ gforth-obsolete
98: k-f10 k-shift-mask or constant s-k10 ( -- u ) \ gforth-obsolete
99: k-f11 k-shift-mask or constant s-k11 ( -- u ) \ gforth-obsolete
100: k-f12 k-shift-mask or constant s-k12 ( -- u ) \ gforth-obsolete
1.1 anton 101:
102: \ helper word
103: \ print a key sequence:
1.17 anton 104: 0 [IF]
105: : key-sequence ( -- )
106: key begin
107: cr dup . emit
108: key? while
109: key
110: repeat ;
111:
112: : key-sequences ( -- )
113: begin
114: key-sequence cr
115: again ;
116: [THEN]
1.1 anton 117:
118: create key-buffer 8 chars allot
119: 2variable key-buffered key-buffer 0 key-buffered 2!
120:
121: : char-append-buffer ( c addr -- )
122: tuck 2@ chars + c!
123: dup 2@ 1+ rot 2! ;
124:
125: :noname ( -- c )
126: \ buffered key
127: key-buffered 2@ dup if
1.17 anton 128: 1- 2dup key-buffered 2!
129: chars + c@
1.1 anton 130: else
1.17 anton 131: 2drop defers key
1.1 anton 132: then ;
133: is key
134:
135: : unkey ( c -- )
136: key-buffered char-append-buffer ;
137:
138: : unkeys ( addr u -- )
139: -1 swap 1- -do
1.17 anton 140: dup i chars + c@ unkey
141: 1 -loop
1.1 anton 142: drop ;
143:
144: :noname ( -- flag )
145: key-buffered 2@ nip 0<> defers key? or ;
146: is key?
147:
148: table constant esc-sequences \ and prefixes
149:
150: create ekey-buffer 8 chars allot
151: 2variable ekey-buffered
152:
1.10 pazsan 153: [IFUNDEF] #esc 27 Constant #esc [THEN]
1.1 anton 154:
155: : esc-prefix ( -- u )
1.6 anton 156: key? if
1.17 anton 157: key ekey-buffered char-append-buffer
158: ekey-buffered 2@ esc-sequences search-wordlist
159: if
160: execute exit
161: endif
1.6 anton 162: endif
163: ekey-buffered 2@ unkeys #esc ;
1.1 anton 164:
1.17 anton 165: : esc-sequence ( u1 addr u -- ; name execution: -- u2 ) recursive
166: \ define escape sequence addr u (=name) to have value u1; if u1=0,
167: \ addr u is a prefix of some other sequence (with key code u2);
168: \ also, define all prefixes of addr u if necessary.
1.1 anton 169: 2dup 1- dup
170: if
1.17 anton 171: 2dup esc-sequences search-wordlist
172: if
173: drop 2drop
174: else
175: 0 -rot esc-sequence \ define the prefixes
176: then
177: else
178: 2drop
179: then ( u1 addr u )
180: nextname dup if ( u1 )
181: constant \ full sequence for a key
1.1 anton 182: else
1.17 anton 183: drop ['] esc-prefix alias
184: endif ;
1.1 anton 185:
1.2 crook 186: \ nac02dec1999 exclude the escape sequences if we are using crossdoc.fs to generate
187: \ a documentation file. Do this because key sequences [ and OR here clash with
188: \ standard names and so prevent them appearing in the documentation.
189: [IFUNDEF] put-doc-entry
1.1 anton 190: get-current esc-sequences set-current
191:
192: \ esc sequences (derived by using key-sequence in an xterm)
1.17 anton 193: k-left s" [D" esc-sequence
194: k-right s" [C" esc-sequence
195: k-up s" [A" esc-sequence
196: k-down s" [B" esc-sequence
197: k-home s" [H" esc-sequence
198: k-end s" [F" esc-sequence
199: k-prior s" [5~" esc-sequence
200: k-next s" [6~" esc-sequence
201: k-insert s" [2~" esc-sequence
202: k-delete s" [3~" esc-sequence
203:
204: k-left k-shift-mask or s" [1;2D" esc-sequence
205: k-right k-shift-mask or s" [1;2C" esc-sequence
206: k-up k-shift-mask or s" [1;2A" esc-sequence
207: k-down k-shift-mask or s" [1;2B" esc-sequence
208: k-home k-shift-mask or s" [1;2H" esc-sequence
209: k-end k-shift-mask or s" [1;2F" esc-sequence
210: k-prior k-shift-mask or s" [5;2~" esc-sequence
211: k-next k-shift-mask or s" [6;2~" esc-sequence
212: k-insert k-shift-mask or s" [2;2~" esc-sequence
213: k-delete k-shift-mask or s" [3;2~" esc-sequence
214:
215: k-left k-ctrl-mask or s" [1;5D" esc-sequence
216: k-right k-ctrl-mask or s" [1;5C" esc-sequence
217: k-up k-ctrl-mask or s" [1;5A" esc-sequence
218: k-down k-ctrl-mask or s" [1;5B" esc-sequence
219: k-home k-ctrl-mask or s" [1;5H" esc-sequence
220: k-end k-ctrl-mask or s" [1;5F" esc-sequence
221: k-prior k-ctrl-mask or s" [5;5~" esc-sequence
222: k-next k-ctrl-mask or s" [6;5~" esc-sequence
223: k-insert k-ctrl-mask or s" [2;5~" esc-sequence
224: k-delete k-ctrl-mask or s" [3;5~" esc-sequence
225:
226: k-left k-alt-mask or s" [1;3D" esc-sequence
227: k-right k-alt-mask or s" [1;3C" esc-sequence
228: k-up k-alt-mask or s" [1;3A" esc-sequence
229: k-down k-alt-mask or s" [1;3B" esc-sequence
230: k-home k-alt-mask or s" [1;3H" esc-sequence
231: k-end k-alt-mask or s" [1;3F" esc-sequence
232: k-prior k-alt-mask or s" [5;3~" esc-sequence
233: k-next k-alt-mask or s" [6;3~" esc-sequence
234: k-insert k-alt-mask or s" [2;3~" esc-sequence
235: k-delete k-alt-mask or s" [3;3~" esc-sequence
236:
237: k1 s" OP" esc-sequence
238: k2 s" OQ" esc-sequence
239: k3 s" OR" esc-sequence
240: k4 s" OS" esc-sequence
241: k5 s" [15~" esc-sequence
242: k6 s" [17~" esc-sequence
243: k7 s" [18~" esc-sequence
244: k8 s" [19~" esc-sequence
245: k9 s" [20~" esc-sequence
246: k10 s" [21~" esc-sequence
247: k11 s" [23~" esc-sequence
248: k12 s" [24~" esc-sequence
249:
250: s-k1 s" [1;2P" esc-sequence
251: s-k2 s" [1;2Q" esc-sequence
252: s-k3 s" [1;2R" esc-sequence
253: s-k4 s" [1;2S" esc-sequence
254: s-k5 s" [15;2~" esc-sequence
255: s-k6 s" [17;2~" esc-sequence
256: s-k7 s" [18;2~" esc-sequence
257: s-k8 s" [19;2~" esc-sequence
258: s-k9 s" [20;2~" esc-sequence
259: s-k10 s" [21;2~" esc-sequence
260: s-k11 s" [23;2~" esc-sequence
261: s-k12 s" [24;2~" esc-sequence
262:
263: k-f1 k-ctrl-mask or s" [1;5P" esc-sequence
264: k-f2 k-ctrl-mask or s" [1;5Q" esc-sequence
265: k-f3 k-ctrl-mask or s" [1;5R" esc-sequence
266: k-f4 k-ctrl-mask or s" [1;5S" esc-sequence
267: k-f5 k-ctrl-mask or s" [15;5~" esc-sequence
268: k-f6 k-ctrl-mask or s" [17;5~" esc-sequence
269: k-f7 k-ctrl-mask or s" [18;5~" esc-sequence
270: k-f8 k-ctrl-mask or s" [19;5~" esc-sequence
271: k-f9 k-ctrl-mask or s" [20;5~" esc-sequence
272: k-f10 k-ctrl-mask or s" [21;5~" esc-sequence
273: k-f11 k-ctrl-mask or s" [23;5~" esc-sequence
274: k-f12 k-ctrl-mask or s" [24;5~" esc-sequence
275:
276: k-f1 k-alt-mask or s" [1;3P" esc-sequence
277: k-f2 k-alt-mask or s" [1;3Q" esc-sequence
278: k-f3 k-alt-mask or s" [1;3R" esc-sequence
279: k-f4 k-alt-mask or s" [1;3S" esc-sequence
280: k-f5 k-alt-mask or s" [15;3~" esc-sequence
281: k-f6 k-alt-mask or s" [17;3~" esc-sequence
282: k-f7 k-alt-mask or s" [18;3~" esc-sequence
283: k-f8 k-alt-mask or s" [19;3~" esc-sequence
284: k-f9 k-alt-mask or s" [20;3~" esc-sequence
285: k-f10 k-alt-mask or s" [21;3~" esc-sequence
286: k-f11 k-alt-mask or s" [23;3~" esc-sequence
287: k-f12 k-alt-mask or s" [24;3~" esc-sequence
1.4 anton 288:
289: \ esc sequences from Linux console:
290:
1.17 anton 291: k1 s" [[A" esc-sequence
292: k2 s" [[B" esc-sequence
293: k3 s" [[C" esc-sequence
294: k4 s" [[D" esc-sequence
295: k5 s" [[E" esc-sequence
296: \ k-delete s" [3~" esc-sequence \ duplicate from above
297: k-home s" [1~" esc-sequence
298: k-end s" [4~" esc-sequence
299:
300: s-k1 s" [25~" esc-sequence
301: s-k2 s" [26~" esc-sequence
302: s-k3 s" [28~" esc-sequence
303: s-k4 s" [29~" esc-sequence
304: s-k5 s" [31~" esc-sequence
305: s-k6 s" [32~" esc-sequence
306: s-k7 s" [33~" esc-sequence
307: s-k8 s" [34~" esc-sequence
1.1 anton 308:
309: set-current
1.2 crook 310: [ENDIF]
1.1 anton 311:
312: : clear-ekey-buffer ( -- )
1.12 anton 313: ekey-buffer 0 ekey-buffered 2! ;
1.1 anton 314:
1.2 crook 315: : ekey ( -- u ) \ facility-ext e-key
1.12 anton 316: \G Receive a keyboard event @var{u} (encoding implementation-defined).
1.1 anton 317: key dup #esc =
318: if
1.17 anton 319: drop clear-ekey-buffer
320: esc-prefix
1.1 anton 321: then ;
322:
1.2 crook 323: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
1.12 anton 324: \G Convert keyboard event @var{u} into character @code{c} if possible.
1.15 pazsan 325: dup k-left u< ; \ k-left must be first!
1.1 anton 326:
1.17 anton 327: : ekey>fkey ( u1 -- u2 f ) \ X:ekeys
328: \G If u1 is a keyboard event in the special key set, convert
329: \G keyboard event @var{u1} into key id @var{u2} and return true;
330: \G otherwise return @var{u1} and false.
331: ekey>char 0= ;
332:
1.12 anton 333: ' key? alias ekey? ( -- flag ) \ facility-ext e-key-question
1.14 anton 334: \G True if a keyboard event is available.
1.1 anton 335:
1.7 anton 336: \ : esc? ( -- flag ) recursive
337: \ key? 0=
338: \ if
1.17 anton 339: \ false exit
1.7 anton 340: \ then
341: \ key ekey-buffered char-append-buffer
342: \ ekey-buffered 2@ esc-sequences search-wordlist
343: \ if
1.17 anton 344: \ ['] esc-prefix =
345: \ if
346: \ esc? exit
347: \ then
1.7 anton 348: \ then
349: \ true ;
350:
351: \ : ekey? ( -- flag ) \ facility-ext e-key-question
352: \ \G Return @code{true} if a keyboard event is available (use
353: \ \G @code{ekey} to receive the event), @code{false} otherwise.
354: \ key?
355: \ if
1.17 anton 356: \ key dup #esc =
357: \ if
358: \ clear-ekey-buffer esc?
359: \ ekey-buffered 2@ unkeys
360: \ else
361: \ true
362: \ then
363: \ swap unkey
1.7 anton 364: \ else
1.17 anton 365: \ false
1.7 anton 366: \ then ;
1.1 anton 367:
1.17 anton 368: 0 [if]
369: : test-ekey?
370: begin
371: begin
372: begin
373: key? until
374: ekey? until
375: .s ekey .s drop
376: again ;
1.1 anton 377: \ test-ekey?
1.17 anton 378: [then]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>