1: \ ekey etc.
2:
3: \ Copyright (C) 1999 Free Software Foundation, Inc.
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
19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
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:
35: : keycode ( "name" -- ; name execution: -- u )
36: create ;
37:
38: keycode k-left
39: keycode k-right
40: keycode k-up
41: keycode k-down
42: keycode k-home
43: keycode k-end
44: \ keycode k-prior \ note: captured by xterm
45: \ keycode k-next \ note: captured by xterm
46: keycode k-insert \ not in pfe
47: \ function/keypad keys
48: keycode k1
49: keycode k2
50: keycode k3
51: keycode k4
52: keycode k5
53: keycode k6
54: keycode k7
55: keycode k8
56: keycode k9
57: keycode k10
58: keycode k11 \ not in pfe
59: keycode k12 \ not in pfe
60: \ shifted function/keypad keys have the same key sequences (in xterm)
61: \ and pfe gives the same keycodes; so what are these keycodes good for?
62: \ keycode s-k1
63: \ keycode s-k2
64: \ keycode s-k3
65: \ keycode s-k4
66: \ keycode s-k5
67: \ keycode s-k6
68: \ keycode s-k7
69: \ keycode s-k8
70: \ keycode s-k9
71: \ keycode s-k10
72: \ keycode s-k11 \ not in pfe
73: \ keycode s-k12 \ not in pfe
74:
75: \ helper word
76: \ print a key sequence:
77: \ : key-sequence ( -- )
78: \ key begin
79: \ cr dup . emit
80: \ key? while
81: \ key
82: \ repeat ;
83:
84: create key-buffer 8 chars allot
85: 2variable key-buffered key-buffer 0 key-buffered 2!
86:
87: : char-append-buffer ( c addr -- )
88: tuck 2@ chars + c!
89: dup 2@ 1+ rot 2! ;
90:
91: :noname ( -- c )
92: \ buffered key
93: key-buffered 2@ dup if
94: 1- 2dup key-buffered 2!
95: chars + c@
96: else
97: 2drop defers key
98: then ;
99: is key
100:
101: : unkey ( c -- )
102: key-buffered char-append-buffer ;
103:
104: : unkeys ( addr u -- )
105: -1 swap 1- -do
106: dup i chars + c@ unkey
107: 1 -loop
108: drop ;
109:
110: :noname ( -- flag )
111: key-buffered 2@ nip 0<> defers key? or ;
112: is key?
113:
114: table constant esc-sequences \ and prefixes
115:
116: create ekey-buffer 8 chars allot
117: 2variable ekey-buffered
118:
119: 27 constant #esc
120:
121: : esc-prefix ( -- u )
122: key ekey-buffered char-append-buffer
123: ekey-buffered 2@ esc-sequences search-wordlist
124: if
125: execute exit
126: else
127: ekey-buffered 2@ unkeys #esc
128: then ;
129:
130: : esc-sequence ( xt addr u -- ; name execution: -- u ) recursive
131: \ define key "name" and all prefixes
132: 2dup 1- dup
133: if
134: 2dup esc-sequences search-wordlist
135: if
136: drop 2drop
137: else
138: ['] esc-prefix -rot esc-sequence
139: then
140: else
141: 2drop
142: then ( xt addr u )
143: nextname alias ;
144:
145: \ nac02dec1999 exclude the escape sequences if we are using crossdoc.fs to generate
146: \ a documentation file. Do this because key sequences [ and OR here clash with
147: \ standard names and so prevent them appearing in the documentation.
148: [IFUNDEF] put-doc-entry
149: get-current esc-sequences set-current
150:
151: \ esc sequences (derived by using key-sequence in an xterm)
152:
153: ' k-left s" [D" esc-sequence
154: ' k-right s" [C" esc-sequence
155: ' k-up s" [A" esc-sequence
156: ' k-down s" [B" esc-sequence
157: ' k-home s" [H" esc-sequence
158: ' k-end s" [F" esc-sequence
159: \ ' k-prior s" [5~" esc-sequence \ from linux console
160: \ ' k-next s" [6~" esc-sequence \ from linux console
161: ' k-insert s" [2~" esc-sequence
162:
163: ' k1 s" OP" esc-sequence
164: ' k2 s" OQ" esc-sequence
165: ' k3 s" OR" esc-sequence
166: ' k4 s" OS" esc-sequence
167: ' k5 s" [15~" esc-sequence
168: ' k6 s" [17~" esc-sequence
169: ' k7 s" [18~" esc-sequence
170: ' k8 s" [19~" esc-sequence
171: ' k9 s" [20~" esc-sequence
172: ' k10 s" [21~" esc-sequence
173: ' k11 s" [23~" esc-sequence
174: ' k12 s" [24~" esc-sequence
175:
176: set-current
177: [ENDIF]
178:
179: : clear-ekey-buffer ( -- )
180: ekey-buffer 0 ekey-buffered 2! ;
181:
182: : ekey ( -- u ) \ facility-ext e-key
183: key dup #esc =
184: if
185: drop clear-ekey-buffer
186: esc-prefix
187: then ;
188:
189: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
190: dup 256 u< ;
191:
192: : esc? ( -- flag ) recursive
193: key? 0=
194: if
195: false exit
196: then
197: key ekey-buffered char-append-buffer
198: ekey-buffered 2@ esc-sequences search-wordlist
199: if
200: ['] esc-prefix =
201: if
202: esc? exit
203: then
204: then
205: true ;
206:
207: : ekey? ( -- flag ) \ facility-ext e-key-question
208: \G Return @code{true} if a keyboard event is available (use
209: \G @code{ekey} to receive the event), @code{false} otherwise.
210: key?
211: if
212: key dup #esc =
213: if
214: clear-ekey-buffer esc?
215: ekey-buffered 2@ unkeys
216: else
217: true
218: then
219: swap unkey
220: else
221: false
222: then ;
223:
224: \ : test-ekey?
225: \ begin
226: \ begin
227: \ begin
228: \ key? until
229: \ ekey? until
230: \ .s ekey .s drop
231: \ again ;
232: \ test-ekey?
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>