File:  [gforth] / gforth / ekey.fs
Revision 1.19: download - view: text, annotated - select for diffs
Mon Dec 31 18:40:24 2007 UTC (16 years, 3 months ago) by anton
Branches: MAIN
CVS tags: v0-7-0, HEAD
updated copyright notices for GPL v3

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

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