Annotation of gforth/ekey.fs, revision 1.17
1.1 anton 1: \ ekey etc.
2:
1.16 anton 3: \ Copyright (C) 1999,2002,2003,2004,2005,2006 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