File:  [gforth] / gforth / ekey.fs
Revision 1.1: download - view: text, annotated - select for diffs
Sun Aug 29 15:45:19 1999 UTC (19 years, 9 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added ekey etc.
updated performance in docs

    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., 675 Mass Ave, Cambridge, MA 02139, 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: get-current esc-sequences set-current
  146: 
  147: \ esc sequences (derived by using key-sequence in an xterm)
  148: 
  149: ' k-left	s" [D"	esc-sequence
  150: ' k-right	s" [C"	esc-sequence
  151: ' k-up		s" [A"	esc-sequence
  152: ' k-down	s" [B"	esc-sequence
  153: ' k-home	s" [H"	esc-sequence
  154: ' k-end		s" [F"	esc-sequence
  155: \ ' k-prior	s" [5~"	esc-sequence \ from linux console
  156: \ ' k-next	s" [6~"	esc-sequence \ from linux console
  157: ' k-insert	s" [2~"	esc-sequence
  158: 
  159: ' k1	s" OP"	esc-sequence
  160: ' k2	s" OQ"	esc-sequence
  161: ' k3	s" OR"	esc-sequence
  162: ' k4	s" OS"	esc-sequence
  163: ' k5	s" [15~" esc-sequence
  164: ' k6	s" [17~" esc-sequence
  165: ' k7	s" [18~" esc-sequence
  166: ' k8	s" [19~" esc-sequence
  167: ' k9	s" [20~" esc-sequence
  168: ' k10	s" [21~" esc-sequence
  169: ' k11	s" [23~" esc-sequence
  170: ' k12	s" [24~" esc-sequence
  171: 
  172: set-current
  173: 
  174: : clear-ekey-buffer ( -- )
  175:       ekey-buffer 0 ekey-buffered 2! ;
  176: 
  177: : ekey ( -- u )
  178:     key dup #esc =
  179:     if
  180: 	drop clear-ekey-buffer
  181: 	esc-prefix
  182:     then ;
  183: 
  184: : ekey>char ( u -- u false | c true )
  185:     dup 256 u< ;
  186: 
  187: : esc? ( -- flag ) recursive
  188:     key? 0=
  189:     if
  190: 	false exit
  191:     then
  192:     key ekey-buffered char-append-buffer
  193:     ekey-buffered 2@ esc-sequences search-wordlist
  194:     if
  195: 	['] esc-prefix =
  196: 	if
  197: 	    esc? exit
  198: 	then
  199:     then
  200:     true ;
  201: 
  202: : ekey? ( -- flag )
  203:     key?
  204:     if
  205: 	key dup #esc =
  206: 	if
  207: 	    clear-ekey-buffer esc?
  208: 	    ekey-buffered 2@ unkeys
  209: 	else
  210: 	    true
  211: 	then
  212: 	swap unkey
  213:     else
  214: 	false
  215:     then ;
  216: 
  217: \ : test-ekey?
  218: \     begin
  219: \ 	begin
  220: \ 	    begin
  221: \ 		key? until
  222: \ 	    ekey? until
  223: \ 	.s ekey .s drop
  224: \     again ;
  225: \ test-ekey?

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