File:  [gforth] / gforth / ekey.fs
Revision 1.20: download - view: text, annotated - select for diffs
Sat Nov 8 15:54:06 2008 UTC (10 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD
Updated version number and date
added TH
added FKEY. SIMPLE-FKEY-STRING
fixed README.vmgen typo

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

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