File:  [gforth] / gforth / ekey.fs
Revision 1.10: download - view: text, annotated - select for diffs
Tue Dec 28 21:09:46 2004 UTC (19 years, 2 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added start-mark/end-mark for error display

    1: \ ekey etc.
    2: 
    3: \ Copyright (C) 1999,2002,2003 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: [IFUNDEF] #esc  27 Constant #esc  [THEN]
  121: 
  122: : esc-prefix ( -- u )
  123:     key? if
  124: 	key ekey-buffered char-append-buffer
  125: 	ekey-buffered 2@ esc-sequences search-wordlist
  126: 	if
  127: 	    execute exit
  128: 	endif
  129:     endif
  130:     ekey-buffered 2@ unkeys #esc ;
  131: 
  132: : esc-sequence ( xt addr u -- ; name execution: -- u ) recursive
  133:     \ define key "name" and all prefixes
  134:     2dup 1- dup
  135:     if
  136: 	2dup esc-sequences search-wordlist
  137: 	if
  138: 	    drop 2drop
  139: 	else
  140: 	    ['] esc-prefix -rot esc-sequence
  141: 	then
  142:     else
  143: 	2drop
  144:     then ( xt addr u )
  145:     nextname alias ;
  146: 
  147: \ nac02dec1999 exclude the escape sequences if we are using crossdoc.fs to generate
  148: \ a documentation file. Do this because key sequences [ and OR here clash with
  149: \ standard names and so prevent them appearing in the documentation. 
  150: [IFUNDEF] put-doc-entry
  151: get-current esc-sequences set-current
  152: 
  153: \ esc sequences (derived by using key-sequence in an xterm)
  154: 
  155: ' k-left	s" [D"	esc-sequence
  156: ' k-right	s" [C"	esc-sequence
  157: ' k-up		s" [A"	esc-sequence
  158: ' k-down	s" [B"	esc-sequence
  159: ' k-home	s" [H"	esc-sequence
  160: ' k-end		s" [F"	esc-sequence
  161: ' k-prior	s" [5~"	esc-sequence
  162: ' k-next	s" [6~"	esc-sequence
  163: ' k-insert	s" [2~"	esc-sequence
  164: 
  165: ' k1	s" OP"	esc-sequence
  166: ' k2	s" OQ"	esc-sequence
  167: ' k3	s" OR"	esc-sequence
  168: ' k4	s" OS"	esc-sequence
  169: ' k5	s" [15~" esc-sequence
  170: ' k6	s" [17~" esc-sequence
  171: ' k7	s" [18~" esc-sequence
  172: ' k8	s" [19~" esc-sequence
  173: ' k9	s" [20~" esc-sequence
  174: ' k10	s" [21~" esc-sequence
  175: ' k11	s" [23~" esc-sequence
  176: ' k12	s" [24~" esc-sequence
  177: 
  178: \ esc sequences from Linux console:
  179: 
  180: ' k1       s" [[A" esc-sequence
  181: ' k2       s" [[B" esc-sequence
  182: ' k3       s" [[C" esc-sequence
  183: ' k4       s" [[D" esc-sequence
  184: ' k5       s" [[E" esc-sequence
  185: ' k-delete s" [3~" esc-sequence
  186: ' k-home   s" [1~" esc-sequence
  187: ' k-end    s" [4~" esc-sequence
  188: 
  189: ' s-k1 s" [25~" esc-sequence
  190: ' s-k2 s" [26~" esc-sequence
  191: ' s-k3 s" [28~" esc-sequence
  192: ' s-k4 s" [29~" esc-sequence
  193: ' s-k5 s" [31~" esc-sequence
  194: ' s-k6 s" [32~" esc-sequence
  195: ' s-k7 s" [33~" esc-sequence
  196: ' s-k8 s" [34~" esc-sequence
  197: 
  198: set-current
  199: [ENDIF]
  200: 
  201: : clear-ekey-buffer ( -- )
  202:       ekey-buffer 0 ekey-buffered 2! ;
  203: 
  204: : ekey ( -- u ) \ facility-ext e-key
  205:     key dup #esc =
  206:     if
  207: 	drop clear-ekey-buffer
  208: 	esc-prefix
  209:     then ;
  210: 
  211: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
  212:     dup 256 u< ;
  213: 
  214: ' key? alias ekey? ( -- flag )
  215: 
  216: \  : esc? ( -- flag ) recursive
  217: \      key? 0=
  218: \      if
  219: \  	false exit
  220: \      then
  221: \      key ekey-buffered char-append-buffer
  222: \      ekey-buffered 2@ esc-sequences search-wordlist
  223: \      if
  224: \  	['] esc-prefix =
  225: \  	if
  226: \  	    esc? exit
  227: \  	then
  228: \      then
  229: \      true ;
  230: 
  231: \  : ekey? ( -- flag ) \ facility-ext e-key-question
  232: \      \G Return @code{true} if a keyboard event is available (use
  233: \      \G @code{ekey} to receive the event), @code{false} otherwise.
  234: \      key?
  235: \      if
  236: \  	key dup #esc =
  237: \  	if
  238: \  	    clear-ekey-buffer esc?
  239: \  	    ekey-buffered 2@ unkeys
  240: \  	else
  241: \  	    true
  242: \  	then
  243: \  	swap unkey
  244: \      else
  245: \  	false
  246: \      then ;
  247: 
  248: \ : test-ekey?
  249: \     begin
  250: \ 	begin
  251: \ 	    begin
  252: \ 		key? until
  253: \ 	    ekey? until
  254: \ 	.s ekey .s drop
  255: \     again ;
  256: \ test-ekey?

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