Annotation of gforth/ekey.fs, revision 1.21
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
178:
1.10 pazsan 179: [IFUNDEF] #esc 27 Constant #esc [THEN]
1.1 anton 180:
181: : esc-prefix ( -- u )
1.6 anton 182: key? if
1.17 anton 183: key ekey-buffered char-append-buffer
184: ekey-buffered 2@ esc-sequences search-wordlist
185: if
186: execute exit
187: endif
1.6 anton 188: endif
189: ekey-buffered 2@ unkeys #esc ;
1.1 anton 190:
1.17 anton 191: : esc-sequence ( u1 addr u -- ; name execution: -- u2 ) recursive
192: \ define escape sequence addr u (=name) to have value u1; if u1=0,
193: \ addr u is a prefix of some other sequence (with key code u2);
194: \ also, define all prefixes of addr u if necessary.
1.1 anton 195: 2dup 1- dup
196: if
1.17 anton 197: 2dup esc-sequences search-wordlist
198: if
199: drop 2drop
200: else
201: 0 -rot esc-sequence \ define the prefixes
202: then
203: else
204: 2drop
205: then ( u1 addr u )
206: nextname dup if ( u1 )
207: constant \ full sequence for a key
1.1 anton 208: else
1.17 anton 209: drop ['] esc-prefix alias
210: endif ;
1.1 anton 211:
1.2 crook 212: \ nac02dec1999 exclude the escape sequences if we are using crossdoc.fs to generate
213: \ a documentation file. Do this because key sequences [ and OR here clash with
214: \ standard names and so prevent them appearing in the documentation.
215: [IFUNDEF] put-doc-entry
1.1 anton 216: get-current esc-sequences set-current
217:
218: \ esc sequences (derived by using key-sequence in an xterm)
1.17 anton 219: k-left s" [D" esc-sequence
220: k-right s" [C" esc-sequence
221: k-up s" [A" esc-sequence
222: k-down s" [B" esc-sequence
223: k-home s" [H" esc-sequence
224: k-end s" [F" esc-sequence
225: k-prior s" [5~" esc-sequence
226: k-next s" [6~" esc-sequence
227: k-insert s" [2~" esc-sequence
228: k-delete s" [3~" esc-sequence
229:
230: k-left k-shift-mask or s" [1;2D" esc-sequence
231: k-right k-shift-mask or s" [1;2C" esc-sequence
232: k-up k-shift-mask or s" [1;2A" esc-sequence
233: k-down k-shift-mask or s" [1;2B" esc-sequence
234: k-home k-shift-mask or s" [1;2H" esc-sequence
235: k-end k-shift-mask or s" [1;2F" esc-sequence
236: k-prior k-shift-mask or s" [5;2~" esc-sequence
237: k-next k-shift-mask or s" [6;2~" esc-sequence
238: k-insert k-shift-mask or s" [2;2~" esc-sequence
239: k-delete k-shift-mask or s" [3;2~" esc-sequence
240:
241: k-left k-ctrl-mask or s" [1;5D" esc-sequence
242: k-right k-ctrl-mask or s" [1;5C" esc-sequence
243: k-up k-ctrl-mask or s" [1;5A" esc-sequence
244: k-down k-ctrl-mask or s" [1;5B" esc-sequence
245: k-home k-ctrl-mask or s" [1;5H" esc-sequence
246: k-end k-ctrl-mask or s" [1;5F" esc-sequence
247: k-prior k-ctrl-mask or s" [5;5~" esc-sequence
248: k-next k-ctrl-mask or s" [6;5~" esc-sequence
249: k-insert k-ctrl-mask or s" [2;5~" esc-sequence
250: k-delete k-ctrl-mask or s" [3;5~" esc-sequence
251:
252: k-left k-alt-mask or s" [1;3D" esc-sequence
253: k-right k-alt-mask or s" [1;3C" esc-sequence
254: k-up k-alt-mask or s" [1;3A" esc-sequence
255: k-down k-alt-mask or s" [1;3B" esc-sequence
256: k-home k-alt-mask or s" [1;3H" esc-sequence
257: k-end k-alt-mask or s" [1;3F" esc-sequence
258: k-prior k-alt-mask or s" [5;3~" esc-sequence
259: k-next k-alt-mask or s" [6;3~" esc-sequence
260: k-insert k-alt-mask or s" [2;3~" esc-sequence
261: k-delete k-alt-mask or s" [3;3~" esc-sequence
262:
263: k1 s" OP" esc-sequence
264: k2 s" OQ" esc-sequence
265: k3 s" OR" esc-sequence
266: k4 s" OS" esc-sequence
267: k5 s" [15~" esc-sequence
268: k6 s" [17~" esc-sequence
269: k7 s" [18~" esc-sequence
270: k8 s" [19~" esc-sequence
271: k9 s" [20~" esc-sequence
272: k10 s" [21~" esc-sequence
273: k11 s" [23~" esc-sequence
274: k12 s" [24~" esc-sequence
275:
276: s-k1 s" [1;2P" esc-sequence
277: s-k2 s" [1;2Q" esc-sequence
278: s-k3 s" [1;2R" esc-sequence
279: s-k4 s" [1;2S" esc-sequence
280: s-k5 s" [15;2~" esc-sequence
281: s-k6 s" [17;2~" esc-sequence
282: s-k7 s" [18;2~" esc-sequence
283: s-k8 s" [19;2~" esc-sequence
284: s-k9 s" [20;2~" esc-sequence
285: s-k10 s" [21;2~" esc-sequence
286: s-k11 s" [23;2~" esc-sequence
287: s-k12 s" [24;2~" esc-sequence
288:
289: k-f1 k-ctrl-mask or s" [1;5P" esc-sequence
290: k-f2 k-ctrl-mask or s" [1;5Q" esc-sequence
291: k-f3 k-ctrl-mask or s" [1;5R" esc-sequence
292: k-f4 k-ctrl-mask or s" [1;5S" esc-sequence
293: k-f5 k-ctrl-mask or s" [15;5~" esc-sequence
294: k-f6 k-ctrl-mask or s" [17;5~" esc-sequence
295: k-f7 k-ctrl-mask or s" [18;5~" esc-sequence
296: k-f8 k-ctrl-mask or s" [19;5~" esc-sequence
297: k-f9 k-ctrl-mask or s" [20;5~" esc-sequence
298: k-f10 k-ctrl-mask or s" [21;5~" esc-sequence
299: k-f11 k-ctrl-mask or s" [23;5~" esc-sequence
300: k-f12 k-ctrl-mask or s" [24;5~" esc-sequence
301:
302: k-f1 k-alt-mask or s" [1;3P" esc-sequence
303: k-f2 k-alt-mask or s" [1;3Q" esc-sequence
304: k-f3 k-alt-mask or s" [1;3R" esc-sequence
305: k-f4 k-alt-mask or s" [1;3S" esc-sequence
306: k-f5 k-alt-mask or s" [15;3~" esc-sequence
307: k-f6 k-alt-mask or s" [17;3~" esc-sequence
308: k-f7 k-alt-mask or s" [18;3~" esc-sequence
309: k-f8 k-alt-mask or s" [19;3~" esc-sequence
310: k-f9 k-alt-mask or s" [20;3~" esc-sequence
311: k-f10 k-alt-mask or s" [21;3~" esc-sequence
312: k-f11 k-alt-mask or s" [23;3~" esc-sequence
313: k-f12 k-alt-mask or s" [24;3~" esc-sequence
1.4 anton 314:
315: \ esc sequences from Linux console:
316:
1.17 anton 317: k1 s" [[A" esc-sequence
318: k2 s" [[B" esc-sequence
319: k3 s" [[C" esc-sequence
320: k4 s" [[D" esc-sequence
321: k5 s" [[E" esc-sequence
322: \ k-delete s" [3~" esc-sequence \ duplicate from above
323: k-home s" [1~" esc-sequence
324: k-end s" [4~" esc-sequence
325:
326: s-k1 s" [25~" esc-sequence
327: s-k2 s" [26~" esc-sequence
328: s-k3 s" [28~" esc-sequence
329: s-k4 s" [29~" esc-sequence
330: s-k5 s" [31~" esc-sequence
331: s-k6 s" [32~" esc-sequence
332: s-k7 s" [33~" esc-sequence
333: s-k8 s" [34~" esc-sequence
1.1 anton 334:
335: set-current
1.2 crook 336: [ENDIF]
1.1 anton 337:
338: : clear-ekey-buffer ( -- )
1.12 anton 339: ekey-buffer 0 ekey-buffered 2! ;
1.1 anton 340:
1.2 crook 341: : ekey ( -- u ) \ facility-ext e-key
1.12 anton 342: \G Receive a keyboard event @var{u} (encoding implementation-defined).
1.1 anton 343: key dup #esc =
344: if
1.17 anton 345: drop clear-ekey-buffer
346: esc-prefix
1.1 anton 347: then ;
348:
1.2 crook 349: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
1.12 anton 350: \G Convert keyboard event @var{u} into character @code{c} if possible.
1.15 pazsan 351: dup k-left u< ; \ k-left must be first!
1.1 anton 352:
1.17 anton 353: : ekey>fkey ( u1 -- u2 f ) \ X:ekeys
354: \G If u1 is a keyboard event in the special key set, convert
355: \G keyboard event @var{u1} into key id @var{u2} and return true;
356: \G otherwise return @var{u1} and false.
357: ekey>char 0= ;
358:
1.12 anton 359: ' key? alias ekey? ( -- flag ) \ facility-ext e-key-question
1.14 anton 360: \G True if a keyboard event is available.
1.1 anton 361:
1.7 anton 362: \ : esc? ( -- flag ) recursive
363: \ key? 0=
364: \ if
1.17 anton 365: \ false exit
1.7 anton 366: \ then
367: \ key ekey-buffered char-append-buffer
368: \ ekey-buffered 2@ esc-sequences search-wordlist
369: \ if
1.17 anton 370: \ ['] esc-prefix =
371: \ if
372: \ esc? exit
373: \ then
1.7 anton 374: \ then
375: \ true ;
376:
377: \ : ekey? ( -- flag ) \ facility-ext e-key-question
378: \ \G Return @code{true} if a keyboard event is available (use
379: \ \G @code{ekey} to receive the event), @code{false} otherwise.
380: \ key?
381: \ if
1.17 anton 382: \ key dup #esc =
383: \ if
384: \ clear-ekey-buffer esc?
385: \ ekey-buffered 2@ unkeys
386: \ else
387: \ true
388: \ then
389: \ swap unkey
1.7 anton 390: \ else
1.17 anton 391: \ false
1.7 anton 392: \ then ;
1.1 anton 393:
1.17 anton 394: 0 [if]
395: : test-ekey?
396: begin
397: begin
398: begin
399: key? until
400: ekey? until
401: .s ekey .s drop
402: again ;
1.1 anton 403: \ test-ekey?
1.17 anton 404: [then]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>