File:  [gforth] / gforth / ekey.fs
Revision 1.18: download - view: text, annotated - select for diffs
Mon Dec 31 17:34:58 2007 UTC (16 years, 2 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright years

    1: \ ekey etc.
    2: 
    3: \ Copyright (C) 1999,2002,2003,2004,2005,2006,2007 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 ( u1 "name" -- u2 ; name execution: -- u )
   36:     dup constant 1+ ;
   37: 
   38: \ most of the keys are also in pfe, except:
   39: \ k-insert, k-delete, k11, k12, s-k11, s-k12
   40: 
   41: $40000000 constant k-shift-mask ( -- u ) \ X:ekeys
   42: $20000000 constant k-ctrl-mask ( -- u )  \ X:ekeys
   43: $10000000 constant k-alt-mask ( -- u )   \ X:ekeys
   44: 
   45: $80000000
   46: keycode k-left   ( -- u ) \ X:ekeys  
   47: keycode k-right  ( -- u ) \ X:ekeys
   48: keycode k-up     ( -- u ) \ X:ekeys
   49: keycode k-down   ( -- u ) \ X:ekeys
   50: keycode k-home   ( -- u ) \ X:ekeys
   51: \G aka Pos1
   52: keycode k-end    ( -- u ) \ X:ekeys
   53: keycode k-prior  ( -- u ) \ X:ekeys
   54: \G aka PgUp
   55: keycode k-next   ( -- u ) \ X:ekeys
   56: \G aka PgDn    
   57: keycode k-insert ( -- u ) \ X:ekeys
   58: keycode k-delete ( -- u ) \ X:ekeys
   59: \ the DEL key on my xterm, not backspace
   60: 
   61: \ function/keypad keys
   62: keycode k-f1  ( -- u ) \ X:ekeys
   63: keycode k-f2  ( -- u ) \ X:ekeys
   64: keycode k-f3  ( -- u ) \ X:ekeys
   65: keycode k-f4  ( -- u ) \ X:ekeys
   66: keycode k-f5  ( -- u ) \ X:ekeys
   67: keycode k-f6  ( -- u ) \ X:ekeys
   68: keycode k-f7  ( -- u ) \ X:ekeys
   69: keycode k-f8  ( -- u ) \ X:ekeys
   70: keycode k-f9  ( -- u ) \ X:ekeys
   71: keycode k-f10 ( -- u ) \ X:ekeys
   72: keycode k-f11 ( -- u ) \ X:ekeys
   73: keycode k-f12 ( -- u ) \ X:ekeys
   74: drop
   75:     
   76: ' k-f1  alias k1  ( -- u ) \ gforth-obsolete
   77: ' k-f2  alias k2  ( -- u ) \ gforth-obsolete
   78: ' k-f3  alias k3  ( -- u ) \ gforth-obsolete
   79: ' k-f4  alias k4  ( -- u ) \ gforth-obsolete
   80: ' k-f5  alias k5  ( -- u ) \ gforth-obsolete
   81: ' k-f6  alias k6  ( -- u ) \ gforth-obsolete
   82: ' k-f7  alias k7  ( -- u ) \ gforth-obsolete
   83: ' k-f8  alias k8  ( -- u ) \ gforth-obsolete
   84: ' k-f9  alias k9  ( -- u ) \ gforth-obsolete
   85: ' k-f10 alias k10 ( -- u ) \ gforth-obsolete
   86: ' k-f11 alias k11 ( -- u ) \ gforth-obsolete
   87: ' k-f12 alias k12 ( -- u ) \ gforth-obsolete
   88: \ shifted fuinction keys (don't work in xterm (same as unshifted, but
   89: \ s-k1..s-k8 work in the Linux console)
   90: k-f1  k-shift-mask or constant s-k1  ( -- u ) \ gforth-obsolete 
   91: k-f2  k-shift-mask or constant s-k2  ( -- u ) \ gforth-obsolete 
   92: k-f3  k-shift-mask or constant s-k3  ( -- u ) \ gforth-obsolete 
   93: k-f4  k-shift-mask or constant s-k4  ( -- u ) \ gforth-obsolete 
   94: k-f5  k-shift-mask or constant s-k5  ( -- u ) \ gforth-obsolete 
   95: k-f6  k-shift-mask or constant s-k6  ( -- u ) \ gforth-obsolete 
   96: k-f7  k-shift-mask or constant s-k7  ( -- u ) \ gforth-obsolete 
   97: k-f8  k-shift-mask or constant s-k8  ( -- u ) \ gforth-obsolete 
   98: k-f9  k-shift-mask or constant s-k9  ( -- u ) \ gforth-obsolete 
   99: k-f10 k-shift-mask or constant s-k10 ( -- u ) \ gforth-obsolete 
  100: k-f11 k-shift-mask or constant s-k11 ( -- u ) \ gforth-obsolete
  101: k-f12 k-shift-mask or constant s-k12 ( -- u ) \ gforth-obsolete
  102: 
  103: \ helper word
  104: \ print a key sequence:
  105: 0 [IF]
  106: : key-sequence  ( -- )
  107:     key begin
  108:         cr dup . emit
  109:         key? while
  110:         key
  111:     repeat ;
  112: 
  113: : key-sequences ( -- )
  114:     begin
  115:         key-sequence cr
  116:     again ;
  117: [THEN]
  118: 
  119: create key-buffer 8 chars allot
  120: 2variable key-buffered  key-buffer 0 key-buffered 2!
  121: 
  122: : char-append-buffer ( c addr -- )
  123:     tuck 2@ chars + c!
  124:     dup 2@ 1+ rot 2! ;
  125: 
  126: :noname ( -- c )
  127:     \ buffered key
  128:     key-buffered 2@ dup if
  129:         1- 2dup key-buffered 2!
  130:         chars + c@
  131:     else
  132:         2drop defers key
  133:     then ;
  134: is key
  135: 
  136: : unkey ( c -- )
  137:     key-buffered char-append-buffer ;
  138:     
  139: : unkeys ( addr u -- )
  140:     -1 swap 1- -do
  141:         dup i chars + c@ unkey
  142:         1 -loop
  143:     drop ;
  144: 
  145: :noname ( -- flag )
  146:     key-buffered 2@ nip 0<> defers key? or ;
  147: is key?
  148: 
  149: table constant esc-sequences \ and prefixes
  150: 
  151: create ekey-buffer 8 chars allot
  152: 2variable ekey-buffered
  153: 
  154: [IFUNDEF] #esc  27 Constant #esc  [THEN]
  155: 
  156: : esc-prefix ( -- u )
  157:     key? if
  158:         key ekey-buffered char-append-buffer
  159:         ekey-buffered 2@ esc-sequences search-wordlist
  160:         if
  161:             execute exit
  162:         endif
  163:     endif
  164:     ekey-buffered 2@ unkeys #esc ;
  165: 
  166: : esc-sequence ( u1 addr u -- ; name execution: -- u2 ) recursive
  167:     \ define escape sequence addr u (=name) to have value u1; if u1=0,
  168:     \ addr u is a prefix of some other sequence (with key code u2);
  169:     \ also, define all prefixes of addr u if necessary.
  170:     2dup 1- dup
  171:     if
  172:         2dup esc-sequences search-wordlist
  173:         if
  174:             drop 2drop
  175:         else
  176:             0 -rot esc-sequence \ define the prefixes
  177:         then
  178:     else
  179:         2drop
  180:     then ( u1 addr u )
  181:     nextname dup if ( u1 )
  182:         constant \ full sequence for a key
  183:     else
  184:         drop ['] esc-prefix alias
  185:     endif ;
  186: 
  187: \ nac02dec1999 exclude the escape sequences if we are using crossdoc.fs to generate
  188: \ a documentation file. Do this because key sequences [ and OR here clash with
  189: \ standard names and so prevent them appearing in the documentation. 
  190: [IFUNDEF] put-doc-entry
  191: get-current esc-sequences set-current
  192: 
  193: \ esc sequences (derived by using key-sequence in an xterm)
  194: k-left   s" [D" esc-sequence
  195: k-right  s" [C" esc-sequence
  196: k-up     s" [A" esc-sequence
  197: k-down   s" [B" esc-sequence
  198: k-home   s" [H" esc-sequence
  199: k-end    s" [F" esc-sequence
  200: k-prior  s" [5~" esc-sequence
  201: k-next   s" [6~" esc-sequence
  202: k-insert s" [2~" esc-sequence
  203: k-delete s" [3~" esc-sequence
  204: 
  205: k-left   k-shift-mask or s" [1;2D" esc-sequence
  206: k-right  k-shift-mask or s" [1;2C" esc-sequence
  207: k-up     k-shift-mask or s" [1;2A" esc-sequence
  208: k-down   k-shift-mask or s" [1;2B" esc-sequence
  209: k-home   k-shift-mask or s" [1;2H" esc-sequence
  210: k-end    k-shift-mask or s" [1;2F" esc-sequence
  211: k-prior  k-shift-mask or s" [5;2~" esc-sequence
  212: k-next   k-shift-mask or s" [6;2~" esc-sequence
  213: k-insert k-shift-mask or s" [2;2~" esc-sequence
  214: k-delete k-shift-mask or s" [3;2~" esc-sequence
  215: 
  216: k-left   k-ctrl-mask  or s" [1;5D" esc-sequence
  217: k-right  k-ctrl-mask  or s" [1;5C" esc-sequence
  218: k-up     k-ctrl-mask  or s" [1;5A" esc-sequence
  219: k-down   k-ctrl-mask  or s" [1;5B" esc-sequence
  220: k-home   k-ctrl-mask  or s" [1;5H" esc-sequence
  221: k-end    k-ctrl-mask  or s" [1;5F" esc-sequence
  222: k-prior  k-ctrl-mask  or s" [5;5~" esc-sequence
  223: k-next   k-ctrl-mask  or s" [6;5~" esc-sequence
  224: k-insert k-ctrl-mask  or s" [2;5~" esc-sequence
  225: k-delete k-ctrl-mask  or s" [3;5~" esc-sequence
  226: 
  227: k-left   k-alt-mask   or s" [1;3D" esc-sequence
  228: k-right  k-alt-mask   or s" [1;3C" esc-sequence
  229: k-up     k-alt-mask   or s" [1;3A" esc-sequence
  230: k-down   k-alt-mask   or s" [1;3B" esc-sequence
  231: k-home   k-alt-mask   or s" [1;3H" esc-sequence
  232: k-end    k-alt-mask   or s" [1;3F" esc-sequence
  233: k-prior  k-alt-mask   or s" [5;3~" esc-sequence
  234: k-next   k-alt-mask   or s" [6;3~" esc-sequence
  235: k-insert k-alt-mask   or s" [2;3~" esc-sequence
  236: k-delete k-alt-mask   or s" [3;3~" esc-sequence
  237: 
  238: k1      s" OP"  esc-sequence
  239: k2      s" OQ"  esc-sequence
  240: k3      s" OR"  esc-sequence
  241: k4      s" OS"  esc-sequence
  242: k5      s" [15~" esc-sequence
  243: k6      s" [17~" esc-sequence
  244: k7      s" [18~" esc-sequence
  245: k8      s" [19~" esc-sequence
  246: k9      s" [20~" esc-sequence
  247: k10     s" [21~" esc-sequence
  248: k11     s" [23~" esc-sequence
  249: k12     s" [24~" esc-sequence
  250: 
  251: s-k1    s" [1;2P" esc-sequence
  252: s-k2    s" [1;2Q" esc-sequence
  253: s-k3    s" [1;2R" esc-sequence
  254: s-k4    s" [1;2S" esc-sequence
  255: s-k5    s" [15;2~" esc-sequence
  256: s-k6    s" [17;2~" esc-sequence
  257: s-k7    s" [18;2~" esc-sequence
  258: s-k8    s" [19;2~" esc-sequence
  259: s-k9    s" [20;2~" esc-sequence
  260: s-k10   s" [21;2~" esc-sequence
  261: s-k11   s" [23;2~" esc-sequence
  262: s-k12   s" [24;2~" esc-sequence
  263: 
  264: k-f1  k-ctrl-mask or  s" [1;5P" esc-sequence
  265: k-f2  k-ctrl-mask or  s" [1;5Q" esc-sequence
  266: k-f3  k-ctrl-mask or  s" [1;5R" esc-sequence
  267: k-f4  k-ctrl-mask or  s" [1;5S" esc-sequence
  268: k-f5  k-ctrl-mask or  s" [15;5~" esc-sequence
  269: k-f6  k-ctrl-mask or  s" [17;5~" esc-sequence
  270: k-f7  k-ctrl-mask or  s" [18;5~" esc-sequence
  271: k-f8  k-ctrl-mask or  s" [19;5~" esc-sequence
  272: k-f9  k-ctrl-mask or  s" [20;5~" esc-sequence
  273: k-f10 k-ctrl-mask or  s" [21;5~" esc-sequence
  274: k-f11 k-ctrl-mask or  s" [23;5~" esc-sequence
  275: k-f12 k-ctrl-mask or  s" [24;5~" esc-sequence
  276: 
  277: k-f1  k-alt-mask  or  s" [1;3P" esc-sequence
  278: k-f2  k-alt-mask  or  s" [1;3Q" esc-sequence
  279: k-f3  k-alt-mask  or  s" [1;3R" esc-sequence
  280: k-f4  k-alt-mask  or  s" [1;3S" esc-sequence
  281: k-f5  k-alt-mask  or  s" [15;3~" esc-sequence
  282: k-f6  k-alt-mask  or  s" [17;3~" esc-sequence
  283: k-f7  k-alt-mask  or  s" [18;3~" esc-sequence
  284: k-f8  k-alt-mask  or  s" [19;3~" esc-sequence
  285: k-f9  k-alt-mask  or  s" [20;3~" esc-sequence
  286: k-f10 k-alt-mask  or  s" [21;3~" esc-sequence
  287: k-f11 k-alt-mask  or  s" [23;3~" esc-sequence
  288: k-f12 k-alt-mask  or  s" [24;3~" esc-sequence
  289: 
  290: \ esc sequences from Linux console:
  291: 
  292: k1       s" [[A" esc-sequence
  293: k2       s" [[B" esc-sequence
  294: k3       s" [[C" esc-sequence
  295: k4       s" [[D" esc-sequence
  296: k5       s" [[E" esc-sequence
  297: \ k-delete s" [3~" esc-sequence \ duplicate from above
  298: k-home   s" [1~" esc-sequence
  299: k-end    s" [4~" esc-sequence
  300: 
  301: s-k1 s" [25~" esc-sequence
  302: s-k2 s" [26~" esc-sequence
  303: s-k3 s" [28~" esc-sequence
  304: s-k4 s" [29~" esc-sequence
  305: s-k5 s" [31~" esc-sequence
  306: s-k6 s" [32~" esc-sequence
  307: s-k7 s" [33~" esc-sequence
  308: s-k8 s" [34~" esc-sequence
  309: 
  310: set-current
  311: [ENDIF]
  312: 
  313: : clear-ekey-buffer ( -- )
  314:     ekey-buffer 0 ekey-buffered 2! ;
  315: 
  316: : ekey ( -- u ) \ facility-ext e-key
  317:     \G Receive a keyboard event @var{u} (encoding implementation-defined).
  318:     key dup #esc =
  319:     if
  320:         drop clear-ekey-buffer
  321:         esc-prefix
  322:     then ;
  323: 
  324: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
  325:     \G Convert keyboard event @var{u} into character @code{c} if possible.
  326:     dup k-left u< ; \ k-left must be first!
  327: 
  328: : ekey>fkey ( u1 -- u2 f ) \ X:ekeys
  329: \G If u1 is a keyboard event in the special key set, convert
  330: \G keyboard event @var{u1} into key id @var{u2} and return true;
  331: \G otherwise return @var{u1} and false.
  332:     ekey>char 0= ;
  333: 
  334: ' key? alias ekey? ( -- flag ) \ facility-ext e-key-question
  335: \G True if a keyboard event is available.
  336: 
  337: \  : esc? ( -- flag ) recursive
  338: \      key? 0=
  339: \      if
  340: \       false exit
  341: \      then
  342: \      key ekey-buffered char-append-buffer
  343: \      ekey-buffered 2@ esc-sequences search-wordlist
  344: \      if
  345: \       ['] esc-prefix =
  346: \       if
  347: \           esc? exit
  348: \       then
  349: \      then
  350: \      true ;
  351: 
  352: \  : ekey? ( -- flag ) \ facility-ext e-key-question
  353: \      \G Return @code{true} if a keyboard event is available (use
  354: \      \G @code{ekey} to receive the event), @code{false} otherwise.
  355: \      key?
  356: \      if
  357: \       key dup #esc =
  358: \       if
  359: \           clear-ekey-buffer esc?
  360: \           ekey-buffered 2@ unkeys
  361: \       else
  362: \           true
  363: \       then
  364: \       swap unkey
  365: \      else
  366: \       false
  367: \      then ;
  368: 
  369: 0 [if]
  370: : test-ekey?
  371:     begin
  372:       begin
  373:           begin
  374:               key? until
  375:           ekey? until
  376:       .s ekey .s drop
  377:     again ;
  378: \ test-ekey?
  379: [then]

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