File:  [gforth] / gforth / ekey.fs
Revision 1.13: download - view: text, annotated - select for diffs
Sat Dec 31 15:46:08 2005 UTC (13 years, 10 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated the copyright year on many files
added FSF copyright header to complex.fs fft.fs regexp-test.fs regexp.fs
added fsl-util.fs to update-copyright-blacklist

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

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