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