File:  [gforth] / gforth / ekey.fs
Revision 1.5: download - view: text, annotated - select for diffs
Fri Oct 26 11:53:21 2001 UTC (17 years, 7 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added some function key names and sequences (from Linux console)
renamed NAME into PARSE-WORD

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>