Annotation of gforth/ekey.fs, revision 1.21

1.1       anton       1: \ ekey etc.
                      2: 
1.20      anton       3: \ Copyright (C) 1999,2002,2003,2004,2005,2006,2007,2008 Free Software Foundation, Inc.
1.1       anton       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
1.19      anton       9: \ as published by the Free Software Foundation, either version 3
1.1       anton      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
1.19      anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1       anton      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: 
1.20      anton      34: $80000000 constant keycode-start
                     35: $80000016 constant keycode-limit
                     36: 
                     37: create keycode-table keycode-limit keycode-start - cells allot
                     38: 
1.17      anton      39: : keycode ( u1 "name" -- u2 ; name execution: -- u )
1.20      anton      40:     dup keycode-limit keycode-start within -11 and throw
                     41:     dup constant
                     42:     dup latest keycode-table rot keycode-start - th !
                     43:     1+ ;
1.1       anton      44: 
1.12      anton      45: \ most of the keys are also in pfe, except:
                     46: \ k-insert, k-delete, k11, k12, s-k11, s-k12
                     47: 
1.17      anton      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: 
1.21    ! anton      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.
1.20      anton      57:     dup keycode-limit keycode-start within -24 and throw
                     58:     keycode-table swap keycode-start - th @ name>string ;
                     59: 
1.21    ! anton      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.
1.20      anton      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
1.17      anton      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
1.12      anton      76: \G aka Pos1
1.17      anton      77: keycode k-end    ( -- u ) \ X:ekeys
                     78: keycode k-prior  ( -- u ) \ X:ekeys
1.12      anton      79: \G aka PgUp
1.17      anton      80: keycode k-next   ( -- u ) \ X:ekeys
1.12      anton      81: \G aka PgDn    
1.17      anton      82: keycode k-insert ( -- u ) \ X:ekeys
                     83: keycode k-delete ( -- u ) \ X:ekeys
                     84: \ the DEL key on my xterm, not backspace
1.12      anton      85: 
1.1       anton      86: \ function/keypad keys
1.17      anton      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
1.5       anton     113: \ shifted fuinction keys (don't work in xterm (same as unshifted, but
                    114: \ s-k1..s-k8 work in the Linux console)
1.17      anton     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
1.1       anton     127: 
                    128: \ helper word
                    129: \ print a key sequence:
1.17      anton     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]
1.1       anton     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
1.17      anton     154:         1- 2dup key-buffered 2!
                    155:         chars + c@
1.1       anton     156:     else
1.17      anton     157:         2drop defers key
1.1       anton     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
1.17      anton     166:         dup i chars + c@ unkey
                    167:         1 -loop
1.1       anton     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: 
1.10      pazsan    179: [IFUNDEF] #esc  27 Constant #esc  [THEN]
1.1       anton     180: 
                    181: : esc-prefix ( -- u )
1.6       anton     182:     key? if
1.17      anton     183:         key ekey-buffered char-append-buffer
                    184:         ekey-buffered 2@ esc-sequences search-wordlist
                    185:         if
                    186:             execute exit
                    187:         endif
1.6       anton     188:     endif
                    189:     ekey-buffered 2@ unkeys #esc ;
1.1       anton     190: 
1.17      anton     191: : esc-sequence ( u1 addr u -- ; name execution: -- u2 ) recursive
                    192:     \ define escape sequence addr u (=name) to have value u1; if u1=0,
                    193:     \ addr u is a prefix of some other sequence (with key code u2);
                    194:     \ also, define all prefixes of addr u if necessary.
1.1       anton     195:     2dup 1- dup
                    196:     if
1.17      anton     197:         2dup esc-sequences search-wordlist
                    198:         if
                    199:             drop 2drop
                    200:         else
                    201:             0 -rot esc-sequence \ define the prefixes
                    202:         then
                    203:     else
                    204:         2drop
                    205:     then ( u1 addr u )
                    206:     nextname dup if ( u1 )
                    207:         constant \ full sequence for a key
1.1       anton     208:     else
1.17      anton     209:         drop ['] esc-prefix alias
                    210:     endif ;
1.1       anton     211: 
1.2       crook     212: \ nac02dec1999 exclude the escape sequences if we are using crossdoc.fs to generate
                    213: \ a documentation file. Do this because key sequences [ and OR here clash with
                    214: \ standard names and so prevent them appearing in the documentation. 
                    215: [IFUNDEF] put-doc-entry
1.1       anton     216: get-current esc-sequences set-current
                    217: 
                    218: \ esc sequences (derived by using key-sequence in an xterm)
1.17      anton     219: k-left   s" [D" esc-sequence
                    220: k-right  s" [C" esc-sequence
                    221: k-up     s" [A" esc-sequence
                    222: k-down   s" [B" esc-sequence
                    223: k-home   s" [H" esc-sequence
                    224: k-end    s" [F" esc-sequence
                    225: k-prior  s" [5~" esc-sequence
                    226: k-next   s" [6~" esc-sequence
                    227: k-insert s" [2~" esc-sequence
                    228: k-delete s" [3~" esc-sequence
                    229: 
                    230: k-left   k-shift-mask or s" [1;2D" esc-sequence
                    231: k-right  k-shift-mask or s" [1;2C" esc-sequence
                    232: k-up     k-shift-mask or s" [1;2A" esc-sequence
                    233: k-down   k-shift-mask or s" [1;2B" esc-sequence
                    234: k-home   k-shift-mask or s" [1;2H" esc-sequence
                    235: k-end    k-shift-mask or s" [1;2F" esc-sequence
                    236: k-prior  k-shift-mask or s" [5;2~" esc-sequence
                    237: k-next   k-shift-mask or s" [6;2~" esc-sequence
                    238: k-insert k-shift-mask or s" [2;2~" esc-sequence
                    239: k-delete k-shift-mask or s" [3;2~" esc-sequence
                    240: 
                    241: k-left   k-ctrl-mask  or s" [1;5D" esc-sequence
                    242: k-right  k-ctrl-mask  or s" [1;5C" esc-sequence
                    243: k-up     k-ctrl-mask  or s" [1;5A" esc-sequence
                    244: k-down   k-ctrl-mask  or s" [1;5B" esc-sequence
                    245: k-home   k-ctrl-mask  or s" [1;5H" esc-sequence
                    246: k-end    k-ctrl-mask  or s" [1;5F" esc-sequence
                    247: k-prior  k-ctrl-mask  or s" [5;5~" esc-sequence
                    248: k-next   k-ctrl-mask  or s" [6;5~" esc-sequence
                    249: k-insert k-ctrl-mask  or s" [2;5~" esc-sequence
                    250: k-delete k-ctrl-mask  or s" [3;5~" esc-sequence
                    251: 
                    252: k-left   k-alt-mask   or s" [1;3D" esc-sequence
                    253: k-right  k-alt-mask   or s" [1;3C" esc-sequence
                    254: k-up     k-alt-mask   or s" [1;3A" esc-sequence
                    255: k-down   k-alt-mask   or s" [1;3B" esc-sequence
                    256: k-home   k-alt-mask   or s" [1;3H" esc-sequence
                    257: k-end    k-alt-mask   or s" [1;3F" esc-sequence
                    258: k-prior  k-alt-mask   or s" [5;3~" esc-sequence
                    259: k-next   k-alt-mask   or s" [6;3~" esc-sequence
                    260: k-insert k-alt-mask   or s" [2;3~" esc-sequence
                    261: k-delete k-alt-mask   or s" [3;3~" esc-sequence
                    262: 
                    263: k1      s" OP"  esc-sequence
                    264: k2      s" OQ"  esc-sequence
                    265: k3      s" OR"  esc-sequence
                    266: k4      s" OS"  esc-sequence
                    267: k5      s" [15~" esc-sequence
                    268: k6      s" [17~" esc-sequence
                    269: k7      s" [18~" esc-sequence
                    270: k8      s" [19~" esc-sequence
                    271: k9      s" [20~" esc-sequence
                    272: k10     s" [21~" esc-sequence
                    273: k11     s" [23~" esc-sequence
                    274: k12     s" [24~" esc-sequence
                    275: 
                    276: s-k1    s" [1;2P" esc-sequence
                    277: s-k2    s" [1;2Q" esc-sequence
                    278: s-k3    s" [1;2R" esc-sequence
                    279: s-k4    s" [1;2S" esc-sequence
                    280: s-k5    s" [15;2~" esc-sequence
                    281: s-k6    s" [17;2~" esc-sequence
                    282: s-k7    s" [18;2~" esc-sequence
                    283: s-k8    s" [19;2~" esc-sequence
                    284: s-k9    s" [20;2~" esc-sequence
                    285: s-k10   s" [21;2~" esc-sequence
                    286: s-k11   s" [23;2~" esc-sequence
                    287: s-k12   s" [24;2~" esc-sequence
                    288: 
                    289: k-f1  k-ctrl-mask or  s" [1;5P" esc-sequence
                    290: k-f2  k-ctrl-mask or  s" [1;5Q" esc-sequence
                    291: k-f3  k-ctrl-mask or  s" [1;5R" esc-sequence
                    292: k-f4  k-ctrl-mask or  s" [1;5S" esc-sequence
                    293: k-f5  k-ctrl-mask or  s" [15;5~" esc-sequence
                    294: k-f6  k-ctrl-mask or  s" [17;5~" esc-sequence
                    295: k-f7  k-ctrl-mask or  s" [18;5~" esc-sequence
                    296: k-f8  k-ctrl-mask or  s" [19;5~" esc-sequence
                    297: k-f9  k-ctrl-mask or  s" [20;5~" esc-sequence
                    298: k-f10 k-ctrl-mask or  s" [21;5~" esc-sequence
                    299: k-f11 k-ctrl-mask or  s" [23;5~" esc-sequence
                    300: k-f12 k-ctrl-mask or  s" [24;5~" esc-sequence
                    301: 
                    302: k-f1  k-alt-mask  or  s" [1;3P" esc-sequence
                    303: k-f2  k-alt-mask  or  s" [1;3Q" esc-sequence
                    304: k-f3  k-alt-mask  or  s" [1;3R" esc-sequence
                    305: k-f4  k-alt-mask  or  s" [1;3S" esc-sequence
                    306: k-f5  k-alt-mask  or  s" [15;3~" esc-sequence
                    307: k-f6  k-alt-mask  or  s" [17;3~" esc-sequence
                    308: k-f7  k-alt-mask  or  s" [18;3~" esc-sequence
                    309: k-f8  k-alt-mask  or  s" [19;3~" esc-sequence
                    310: k-f9  k-alt-mask  or  s" [20;3~" esc-sequence
                    311: k-f10 k-alt-mask  or  s" [21;3~" esc-sequence
                    312: k-f11 k-alt-mask  or  s" [23;3~" esc-sequence
                    313: k-f12 k-alt-mask  or  s" [24;3~" esc-sequence
1.4       anton     314: 
                    315: \ esc sequences from Linux console:
                    316: 
1.17      anton     317: k1       s" [[A" esc-sequence
                    318: k2       s" [[B" esc-sequence
                    319: k3       s" [[C" esc-sequence
                    320: k4       s" [[D" esc-sequence
                    321: k5       s" [[E" esc-sequence
                    322: \ k-delete s" [3~" esc-sequence \ duplicate from above
                    323: k-home   s" [1~" esc-sequence
                    324: k-end    s" [4~" esc-sequence
                    325: 
                    326: s-k1 s" [25~" esc-sequence
                    327: s-k2 s" [26~" esc-sequence
                    328: s-k3 s" [28~" esc-sequence
                    329: s-k4 s" [29~" esc-sequence
                    330: s-k5 s" [31~" esc-sequence
                    331: s-k6 s" [32~" esc-sequence
                    332: s-k7 s" [33~" esc-sequence
                    333: s-k8 s" [34~" esc-sequence
1.1       anton     334: 
                    335: set-current
1.2       crook     336: [ENDIF]
1.1       anton     337: 
                    338: : clear-ekey-buffer ( -- )
1.12      anton     339:     ekey-buffer 0 ekey-buffered 2! ;
1.1       anton     340: 
1.2       crook     341: : ekey ( -- u ) \ facility-ext e-key
1.12      anton     342:     \G Receive a keyboard event @var{u} (encoding implementation-defined).
1.1       anton     343:     key dup #esc =
                    344:     if
1.17      anton     345:         drop clear-ekey-buffer
                    346:         esc-prefix
1.1       anton     347:     then ;
                    348: 
1.2       crook     349: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
1.12      anton     350:     \G Convert keyboard event @var{u} into character @code{c} if possible.
1.15      pazsan    351:     dup k-left u< ; \ k-left must be first!
1.1       anton     352: 
1.17      anton     353: : ekey>fkey ( u1 -- u2 f ) \ X:ekeys
                    354: \G If u1 is a keyboard event in the special key set, convert
                    355: \G keyboard event @var{u1} into key id @var{u2} and return true;
                    356: \G otherwise return @var{u1} and false.
                    357:     ekey>char 0= ;
                    358: 
1.12      anton     359: ' key? alias ekey? ( -- flag ) \ facility-ext e-key-question
1.14      anton     360: \G True if a keyboard event is available.
1.1       anton     361: 
1.7       anton     362: \  : esc? ( -- flag ) recursive
                    363: \      key? 0=
                    364: \      if
1.17      anton     365: \       false exit
1.7       anton     366: \      then
                    367: \      key ekey-buffered char-append-buffer
                    368: \      ekey-buffered 2@ esc-sequences search-wordlist
                    369: \      if
1.17      anton     370: \       ['] esc-prefix =
                    371: \       if
                    372: \           esc? exit
                    373: \       then
1.7       anton     374: \      then
                    375: \      true ;
                    376: 
                    377: \  : ekey? ( -- flag ) \ facility-ext e-key-question
                    378: \      \G Return @code{true} if a keyboard event is available (use
                    379: \      \G @code{ekey} to receive the event), @code{false} otherwise.
                    380: \      key?
                    381: \      if
1.17      anton     382: \       key dup #esc =
                    383: \       if
                    384: \           clear-ekey-buffer esc?
                    385: \           ekey-buffered 2@ unkeys
                    386: \       else
                    387: \           true
                    388: \       then
                    389: \       swap unkey
1.7       anton     390: \      else
1.17      anton     391: \       false
1.7       anton     392: \      then ;
1.1       anton     393: 
1.17      anton     394: 0 [if]
                    395: : test-ekey?
                    396:     begin
                    397:       begin
                    398:           begin
                    399:               key? until
                    400:           ekey? until
                    401:       .s ekey .s drop
                    402:     again ;
1.1       anton     403: \ test-ekey?
1.17      anton     404: [then]

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