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