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