File:  [gforth] / gforth / ekey.fs
Revision 1.24: download - view: text, annotated - select for diffs
Mon Nov 24 15:35:24 2008 UTC (10 years, 11 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Alias ekey? to xkey? if xchar wordset is present

    1: \ ekey etc.
    2: 
    3: \ Copyright (C) 1999,2002,2003,2004,2005,2006,2007,2008 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 3
   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, see http://www.gnu.org/licenses/.
   19: 
   20: 
   21: \ this implementation of EKEY just translates VT100/ANSI escape
   22: \ sequences to ekeys.
   23: 
   24: \ Caveats: It also translates the sequences if they were not generated
   25: \ by pressing the key; moreover, it waits until a complete sequence or
   26: \ an invalid prefix to a sequence has arrived before reporting true in
   27: \ EKEY? and before completing EKEY.  One way to fix this would be to
   28: \ use timeouts when waiting for the next key; however, this may lead
   29: \ to situations in slow networks where single events result in several
   30: \ EKEYs, which appears less desirable to me.
   31: 
   32: \ The keycode names are compatible with pfe-0.9.14
   33: 
   34: $80000000 constant keycode-start
   35: $80000016 constant keycode-limit
   36: 
   37: create keycode-table keycode-limit keycode-start - cells allot
   38: 
   39: : keycode ( u1 "name" -- u2 ; name execution: -- u )
   40:     dup keycode-limit keycode-start within -11 and throw
   41:     dup constant
   42:     dup latest keycode-table rot keycode-start - th !
   43:     1+ ;
   44: 
   45: \ most of the keys are also in pfe, except:
   46: \ k-insert, k-delete, k11, k12, s-k11, s-k12
   47: 
   48: $40000000 constant k-shift-mask ( -- u ) \ X:ekeys
   49: $20000000 constant k-ctrl-mask ( -- u )  \ X:ekeys
   50: $10000000 constant k-alt-mask ( -- u )   \ X:ekeys
   51: 
   52: : simple-fkey-string ( u1 -- c-addr u ) \ gforth
   53:     \G @i{c-addr u} is the string name of the function key @i{u1}.
   54:     \G Only works for simple function keys without modifier masks.
   55:     \G Any @i{u1} that does not correspond to a simple function key
   56:     \G currently produces an exception.
   57:     dup keycode-limit keycode-start within -24 and throw
   58:     keycode-table swap keycode-start - th @ name>string ;
   59: 
   60: : fkey. ( u -- ) \ gforth fkey-dot
   61:     \G Print a string representation for the function key @i{u}.
   62:     \G @i{U} must be a function key (possibly with modifier masks),
   63:     \G otherwise there may be an exception.
   64:     dup [ k-shift-mask k-ctrl-mask k-alt-mask or or invert ] literal and
   65:     simple-fkey-string type
   66:     dup k-shift-mask and if ."  k-shift-mask or" then
   67:     dup k-ctrl-mask  and if ."  k-ctrl-mask or"  then
   68:         k-alt-mask   and if ."  k-alt-mask or"   then ;
   69: 
   70: keycode-start
   71: keycode k-left   ( -- u ) \ X:ekeys  
   72: keycode k-right  ( -- u ) \ X:ekeys
   73: keycode k-up     ( -- u ) \ X:ekeys
   74: keycode k-down   ( -- u ) \ X:ekeys
   75: keycode k-home   ( -- u ) \ X:ekeys
   76: \G aka Pos1
   77: keycode k-end    ( -- u ) \ X:ekeys
   78: keycode k-prior  ( -- u ) \ X:ekeys
   79: \G aka PgUp
   80: keycode k-next   ( -- u ) \ X:ekeys
   81: \G aka PgDn    
   82: keycode k-insert ( -- u ) \ X:ekeys
   83: keycode k-delete ( -- u ) \ X:ekeys
   84: \ the DEL key on my xterm, not backspace
   85: 
   86: \ function/keypad keys
   87: keycode k-f1  ( -- u ) \ X:ekeys
   88: keycode k-f2  ( -- u ) \ X:ekeys
   89: keycode k-f3  ( -- u ) \ X:ekeys
   90: keycode k-f4  ( -- u ) \ X:ekeys
   91: keycode k-f5  ( -- u ) \ X:ekeys
   92: keycode k-f6  ( -- u ) \ X:ekeys
   93: keycode k-f7  ( -- u ) \ X:ekeys
   94: keycode k-f8  ( -- u ) \ X:ekeys
   95: keycode k-f9  ( -- u ) \ X:ekeys
   96: keycode k-f10 ( -- u ) \ X:ekeys
   97: keycode k-f11 ( -- u ) \ X:ekeys
   98: keycode k-f12 ( -- u ) \ X:ekeys
   99: drop
  100:     
  101: ' k-f1  alias k1  ( -- u ) \ gforth-obsolete
  102: ' k-f2  alias k2  ( -- u ) \ gforth-obsolete
  103: ' k-f3  alias k3  ( -- u ) \ gforth-obsolete
  104: ' k-f4  alias k4  ( -- u ) \ gforth-obsolete
  105: ' k-f5  alias k5  ( -- u ) \ gforth-obsolete
  106: ' k-f6  alias k6  ( -- u ) \ gforth-obsolete
  107: ' k-f7  alias k7  ( -- u ) \ gforth-obsolete
  108: ' k-f8  alias k8  ( -- u ) \ gforth-obsolete
  109: ' k-f9  alias k9  ( -- u ) \ gforth-obsolete
  110: ' k-f10 alias k10 ( -- u ) \ gforth-obsolete
  111: ' k-f11 alias k11 ( -- u ) \ gforth-obsolete
  112: ' k-f12 alias k12 ( -- u ) \ gforth-obsolete
  113: \ shifted fuinction keys (don't work in xterm (same as unshifted, but
  114: \ s-k1..s-k8 work in the Linux console)
  115: k-f1  k-shift-mask or constant s-k1  ( -- u ) \ gforth-obsolete 
  116: k-f2  k-shift-mask or constant s-k2  ( -- u ) \ gforth-obsolete 
  117: k-f3  k-shift-mask or constant s-k3  ( -- u ) \ gforth-obsolete 
  118: k-f4  k-shift-mask or constant s-k4  ( -- u ) \ gforth-obsolete 
  119: k-f5  k-shift-mask or constant s-k5  ( -- u ) \ gforth-obsolete 
  120: k-f6  k-shift-mask or constant s-k6  ( -- u ) \ gforth-obsolete 
  121: k-f7  k-shift-mask or constant s-k7  ( -- u ) \ gforth-obsolete 
  122: k-f8  k-shift-mask or constant s-k8  ( -- u ) \ gforth-obsolete 
  123: k-f9  k-shift-mask or constant s-k9  ( -- u ) \ gforth-obsolete 
  124: k-f10 k-shift-mask or constant s-k10 ( -- u ) \ gforth-obsolete 
  125: k-f11 k-shift-mask or constant s-k11 ( -- u ) \ gforth-obsolete
  126: k-f12 k-shift-mask or constant s-k12 ( -- u ) \ gforth-obsolete
  127: 
  128: \ helper word
  129: \ print a key sequence:
  130: 0 [IF]
  131: : key-sequence  ( -- )
  132:     key begin
  133:         cr dup . emit
  134:         key? while
  135:         key
  136:     repeat ;
  137: 
  138: : key-sequences ( -- )
  139:     begin
  140:         key-sequence cr
  141:     again ;
  142: [THEN]
  143: 
  144: create key-buffer 8 chars allot
  145: 2variable key-buffered  key-buffer 0 key-buffered 2!
  146: 
  147: : char-append-buffer ( c addr -- )
  148:     tuck 2@ chars + c!
  149:     dup 2@ 1+ rot 2! ;
  150: 
  151: :noname ( -- c )
  152:     \ buffered key
  153:     key-buffered 2@ dup if
  154:         1- 2dup key-buffered 2!
  155:         chars + c@
  156:     else
  157:         2drop defers key
  158:     then ;
  159: is key
  160: 
  161: : unkey ( c -- )
  162:     key-buffered char-append-buffer ;
  163:     
  164: : unkeys ( addr u -- )
  165:     -1 swap 1- -do
  166:         dup i chars + c@ unkey
  167:         1 -loop
  168:     drop ;
  169: 
  170: :noname ( -- flag )
  171:     key-buffered 2@ nip 0<> defers key? or ;
  172: is key?
  173: 
  174: table constant esc-sequences \ and prefixes
  175: 
  176: create ekey-buffer 8 chars allot
  177: 2variable ekey-buffered
  178: [IFUNDEF] #esc  27 Constant #esc  [THEN]
  179: 
  180: : esc-prefix ( -- u )
  181:     key? if
  182:         key ekey-buffered char-append-buffer
  183:         ekey-buffered 2@ esc-sequences search-wordlist
  184:         if
  185:             execute exit
  186:         endif
  187:     endif
  188:     ekey-buffered 2@ unkeys #esc ;
  189: 
  190: : esc-sequence ( u1 addr u -- ; name execution: -- u2 ) recursive
  191:     \ define escape sequence addr u (=name) to have value u1; if u1=0,
  192:     \ addr u is a prefix of some other sequence (with key code u2);
  193:     \ also, define all prefixes of addr u if necessary.
  194:     2dup 1- dup
  195:     if
  196:         2dup esc-sequences search-wordlist
  197:         if
  198:             drop 2drop
  199:         else
  200:             0 -rot esc-sequence \ define the prefixes
  201:         then
  202:     else
  203:         2drop
  204:     then ( u1 addr u )
  205:     nextname dup if ( u1 )
  206:         constant \ full sequence for a key
  207:     else
  208:         drop ['] esc-prefix alias
  209:     endif ;
  210: 
  211: \ nac02dec1999 exclude the escape sequences if we are using crossdoc.fs to generate
  212: \ a documentation file. Do this because key sequences [ and OR here clash with
  213: \ standard names and so prevent them appearing in the documentation. 
  214: [IFUNDEF] put-doc-entry
  215: get-current esc-sequences set-current
  216: 
  217: \ esc sequences (derived by using key-sequence in an xterm)
  218: k-left   s" [D" esc-sequence
  219: k-right  s" [C" esc-sequence
  220: k-up     s" [A" esc-sequence
  221: k-down   s" [B" esc-sequence
  222: k-home   s" [H" esc-sequence
  223: k-end    s" [F" esc-sequence
  224: k-prior  s" [5~" esc-sequence
  225: k-next   s" [6~" esc-sequence
  226: k-insert s" [2~" esc-sequence
  227: k-delete s" [3~" esc-sequence
  228: 
  229: k-left   k-shift-mask or s" [1;2D" esc-sequence
  230: k-right  k-shift-mask or s" [1;2C" esc-sequence
  231: k-up     k-shift-mask or s" [1;2A" esc-sequence
  232: k-down   k-shift-mask or s" [1;2B" esc-sequence
  233: k-home   k-shift-mask or s" [1;2H" esc-sequence
  234: k-end    k-shift-mask or s" [1;2F" esc-sequence
  235: k-prior  k-shift-mask or s" [5;2~" esc-sequence
  236: k-next   k-shift-mask or s" [6;2~" esc-sequence
  237: k-insert k-shift-mask or s" [2;2~" esc-sequence
  238: k-delete k-shift-mask or s" [3;2~" esc-sequence
  239: 
  240: k-left   k-ctrl-mask  or s" [1;5D" esc-sequence
  241: k-right  k-ctrl-mask  or s" [1;5C" esc-sequence
  242: k-up     k-ctrl-mask  or s" [1;5A" esc-sequence
  243: k-down   k-ctrl-mask  or s" [1;5B" esc-sequence
  244: k-home   k-ctrl-mask  or s" [1;5H" esc-sequence
  245: k-end    k-ctrl-mask  or s" [1;5F" esc-sequence
  246: k-prior  k-ctrl-mask  or s" [5;5~" esc-sequence
  247: k-next   k-ctrl-mask  or s" [6;5~" esc-sequence
  248: k-insert k-ctrl-mask  or s" [2;5~" esc-sequence
  249: k-delete k-ctrl-mask  or s" [3;5~" esc-sequence
  250: 
  251: k-left   k-alt-mask   or s" [1;3D" esc-sequence
  252: k-right  k-alt-mask   or s" [1;3C" esc-sequence
  253: k-up     k-alt-mask   or s" [1;3A" esc-sequence
  254: k-down   k-alt-mask   or s" [1;3B" esc-sequence
  255: k-home   k-alt-mask   or s" [1;3H" esc-sequence
  256: k-end    k-alt-mask   or s" [1;3F" esc-sequence
  257: k-prior  k-alt-mask   or s" [5;3~" esc-sequence
  258: k-next   k-alt-mask   or s" [6;3~" esc-sequence
  259: k-insert k-alt-mask   or s" [2;3~" esc-sequence
  260: k-delete k-alt-mask   or s" [3;3~" esc-sequence
  261: 
  262: k1      s" OP"  esc-sequence
  263: k2      s" OQ"  esc-sequence
  264: k3      s" OR"  esc-sequence
  265: k4      s" OS"  esc-sequence
  266: k5      s" [15~" esc-sequence
  267: k6      s" [17~" esc-sequence
  268: k7      s" [18~" esc-sequence
  269: k8      s" [19~" esc-sequence
  270: k9      s" [20~" esc-sequence
  271: k10     s" [21~" esc-sequence
  272: k11     s" [23~" esc-sequence
  273: k12     s" [24~" esc-sequence
  274: 
  275: s-k1    s" [1;2P" esc-sequence
  276: s-k2    s" [1;2Q" esc-sequence
  277: s-k3    s" [1;2R" esc-sequence
  278: s-k4    s" [1;2S" esc-sequence
  279: s-k5    s" [15;2~" esc-sequence
  280: s-k6    s" [17;2~" esc-sequence
  281: s-k7    s" [18;2~" esc-sequence
  282: s-k8    s" [19;2~" esc-sequence
  283: s-k9    s" [20;2~" esc-sequence
  284: s-k10   s" [21;2~" esc-sequence
  285: s-k11   s" [23;2~" esc-sequence
  286: s-k12   s" [24;2~" esc-sequence
  287: 
  288: k-f1  k-ctrl-mask or  s" [1;5P" esc-sequence
  289: k-f2  k-ctrl-mask or  s" [1;5Q" esc-sequence
  290: k-f3  k-ctrl-mask or  s" [1;5R" esc-sequence
  291: k-f4  k-ctrl-mask or  s" [1;5S" esc-sequence
  292: k-f5  k-ctrl-mask or  s" [15;5~" esc-sequence
  293: k-f6  k-ctrl-mask or  s" [17;5~" esc-sequence
  294: k-f7  k-ctrl-mask or  s" [18;5~" esc-sequence
  295: k-f8  k-ctrl-mask or  s" [19;5~" esc-sequence
  296: k-f9  k-ctrl-mask or  s" [20;5~" esc-sequence
  297: k-f10 k-ctrl-mask or  s" [21;5~" esc-sequence
  298: k-f11 k-ctrl-mask or  s" [23;5~" esc-sequence
  299: k-f12 k-ctrl-mask or  s" [24;5~" esc-sequence
  300: 
  301: k-f1  k-alt-mask  or  s" [1;3P" esc-sequence
  302: k-f2  k-alt-mask  or  s" [1;3Q" esc-sequence
  303: k-f3  k-alt-mask  or  s" [1;3R" esc-sequence
  304: k-f4  k-alt-mask  or  s" [1;3S" esc-sequence
  305: k-f5  k-alt-mask  or  s" [15;3~" esc-sequence
  306: k-f6  k-alt-mask  or  s" [17;3~" esc-sequence
  307: k-f7  k-alt-mask  or  s" [18;3~" esc-sequence
  308: k-f8  k-alt-mask  or  s" [19;3~" esc-sequence
  309: k-f9  k-alt-mask  or  s" [20;3~" esc-sequence
  310: k-f10 k-alt-mask  or  s" [21;3~" esc-sequence
  311: k-f11 k-alt-mask  or  s" [23;3~" esc-sequence
  312: k-f12 k-alt-mask  or  s" [24;3~" esc-sequence
  313: 
  314: \ esc sequences from Linux console:
  315: 
  316: k1       s" [[A" esc-sequence
  317: k2       s" [[B" esc-sequence
  318: k3       s" [[C" esc-sequence
  319: k4       s" [[D" esc-sequence
  320: k5       s" [[E" esc-sequence
  321: \ k-delete s" [3~" esc-sequence \ duplicate from above
  322: k-home   s" [1~" esc-sequence
  323: k-end    s" [4~" esc-sequence
  324: 
  325: s-k1 s" [25~" esc-sequence
  326: s-k2 s" [26~" esc-sequence
  327: s-k3 s" [28~" esc-sequence
  328: s-k4 s" [29~" esc-sequence
  329: s-k5 s" [31~" esc-sequence
  330: s-k6 s" [32~" esc-sequence
  331: s-k7 s" [33~" esc-sequence
  332: s-k8 s" [34~" esc-sequence
  333: 
  334: set-current
  335: [ENDIF]
  336: 
  337: : clear-ekey-buffer ( -- )
  338:     ekey-buffer 0 ekey-buffered 2! ;
  339: 
  340: [IFDEF] max-single-byte
  341:     : read-xkey ( key -- flag )
  342: 	clear-ekey-buffer
  343: 	ekey-buffered char-append-buffer
  344: 	ekey-buffer 1 u8addrlen 1 +do
  345: 	    key? 0= ?leave
  346: 	    key ekey-buffered char-append-buffer
  347: 	loop
  348: 	ekey-buffer 1 u8addrlen ekey-buffered @ = ;
  349:     : get-xkey ( u -- xc )
  350: 	dup max-single-byte u>= if
  351: 	    read-xkey if
  352: 		ekey-buffer xc@+ nip         else
  353: 		ekey-buffered 2@ unkeys key  then
  354: 	then ;
  355:     : xkey? ( -- flag )
  356: 	key? dup if
  357: 	    drop key read-xkey ekey-buffered 2@ unkeys
  358: 	    clear-ekey-buffer  then ;
  359: [THEN]
  360: 
  361: : ekey ( -- u ) \ facility-ext e-key
  362:     \G Receive a keyboard event @var{u} (encoding implementation-defined).
  363:     key dup #esc =
  364:     if
  365:         drop clear-ekey-buffer
  366:         esc-prefix  exit
  367:     then
  368:     [IFDEF] max-single-byte
  369: 	get-xkey
  370:     [THEN]
  371: ;
  372: 
  373: [IFDEF] max-single-byte
  374: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
  375:     \G Convert keyboard event @var{u} into character @code{c} if possible.
  376:     dup max-single-byte u< ; \ k-left must be first!
  377: : ekey>xchar ( u -- u false | xc true ) \ xchar-ext e-key-to-xchar
  378:     \G Convert keyboard event @var{u} into xchar @code{xc} if possible.
  379:     dup k-left u< ; \ k-left must be first!
  380: : ekey>fkey ( u1 -- u2 f ) \ X:ekeys
  381: \G If u1 is a keyboard event in the special key set, convert
  382: \G keyboard event @var{u1} into key id @var{u2} and return true;
  383: \G otherwise return @var{u1} and false.
  384:     ekey>xchar 0= ;
  385: 
  386: ' xkey? alias ekey? ( -- flag ) \ facility-ext e-key-question
  387: [ELSE]
  388: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
  389:     \G Convert keyboard event @var{u} into character @code{c} if possible.
  390:     dup k-left u< ; \ k-left must be first!
  391: : ekey>fkey ( u1 -- u2 f ) \ X:ekeys
  392: \G If u1 is a keyboard event in the special key set, convert
  393: \G keyboard event @var{u1} into key id @var{u2} and return true;
  394: \G otherwise return @var{u1} and false.
  395:     ekey>char 0= ;
  396: 
  397: ' key? alias ekey? ( -- flag ) \ facility-ext e-key-question
  398: [THEN]
  399: 
  400: \G True if a keyboard event is available.
  401: 
  402: \  : esc? ( -- flag ) recursive
  403: \      key? 0=
  404: \      if
  405: \       false exit
  406: \      then
  407: \      key ekey-buffered char-append-buffer
  408: \      ekey-buffered 2@ esc-sequences search-wordlist
  409: \      if
  410: \       ['] esc-prefix =
  411: \       if
  412: \           esc? exit
  413: \       then
  414: \      then
  415: \      true ;
  416: 
  417: \  : ekey? ( -- flag ) \ facility-ext e-key-question
  418: \      \G Return @code{true} if a keyboard event is available (use
  419: \      \G @code{ekey} to receive the event), @code{false} otherwise.
  420: \      key?
  421: \      if
  422: \       key dup #esc =
  423: \       if
  424: \           clear-ekey-buffer esc?
  425: \           ekey-buffered 2@ unkeys
  426: \       else
  427: \           true
  428: \       then
  429: \       swap unkey
  430: \      else
  431: \       false
  432: \      then ;
  433: 
  434: 0 [if]
  435: : test-ekey?
  436:     begin
  437:       begin
  438:           begin
  439:               key? until
  440:           ekey? until
  441:       .s ekey .s drop
  442:     again ;
  443: \ test-ekey?
  444: [then]

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