Annotation of gforth/ekey.fs, revision 1.19

1.1       anton       1: \ ekey etc.
                      2: 
1.18      anton       3: \ Copyright (C) 1999,2002,2003,2004,2005,2006,2007 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.17      anton      34: : keycode ( u1 "name" -- u2 ; name execution: -- u )
                     35:     dup constant 1+ ;
1.1       anton      36: 
1.12      anton      37: \ most of the keys are also in pfe, except:
                     38: \ k-insert, k-delete, k11, k12, s-k11, s-k12
                     39: 
1.17      anton      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
1.12      anton      50: \G aka Pos1
1.17      anton      51: keycode k-end    ( -- u ) \ X:ekeys
                     52: keycode k-prior  ( -- u ) \ X:ekeys
1.12      anton      53: \G aka PgUp
1.17      anton      54: keycode k-next   ( -- u ) \ X:ekeys
1.12      anton      55: \G aka PgDn    
1.17      anton      56: keycode k-insert ( -- u ) \ X:ekeys
                     57: keycode k-delete ( -- u ) \ X:ekeys
                     58: \ the DEL key on my xterm, not backspace
1.12      anton      59: 
1.1       anton      60: \ function/keypad keys
1.17      anton      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
1.5       anton      87: \ shifted fuinction keys (don't work in xterm (same as unshifted, but
                     88: \ s-k1..s-k8 work in the Linux console)
1.17      anton      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
1.1       anton     101: 
                    102: \ helper word
                    103: \ print a key sequence:
1.17      anton     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]
1.1       anton     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
1.17      anton     128:         1- 2dup key-buffered 2!
                    129:         chars + c@
1.1       anton     130:     else
1.17      anton     131:         2drop defers key
1.1       anton     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
1.17      anton     140:         dup i chars + c@ unkey
                    141:         1 -loop
1.1       anton     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: 
1.10      pazsan    153: [IFUNDEF] #esc  27 Constant #esc  [THEN]
1.1       anton     154: 
                    155: : esc-prefix ( -- u )
1.6       anton     156:     key? if
1.17      anton     157:         key ekey-buffered char-append-buffer
                    158:         ekey-buffered 2@ esc-sequences search-wordlist
                    159:         if
                    160:             execute exit
                    161:         endif
1.6       anton     162:     endif
                    163:     ekey-buffered 2@ unkeys #esc ;
1.1       anton     164: 
1.17      anton     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.
1.1       anton     169:     2dup 1- dup
                    170:     if
1.17      anton     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
1.1       anton     182:     else
1.17      anton     183:         drop ['] esc-prefix alias
                    184:     endif ;
1.1       anton     185: 
1.2       crook     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
1.1       anton     190: get-current esc-sequences set-current
                    191: 
                    192: \ esc sequences (derived by using key-sequence in an xterm)
1.17      anton     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
1.4       anton     288: 
                    289: \ esc sequences from Linux console:
                    290: 
1.17      anton     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
1.1       anton     308: 
                    309: set-current
1.2       crook     310: [ENDIF]
1.1       anton     311: 
                    312: : clear-ekey-buffer ( -- )
1.12      anton     313:     ekey-buffer 0 ekey-buffered 2! ;
1.1       anton     314: 
1.2       crook     315: : ekey ( -- u ) \ facility-ext e-key
1.12      anton     316:     \G Receive a keyboard event @var{u} (encoding implementation-defined).
1.1       anton     317:     key dup #esc =
                    318:     if
1.17      anton     319:         drop clear-ekey-buffer
                    320:         esc-prefix
1.1       anton     321:     then ;
                    322: 
1.2       crook     323: : ekey>char ( u -- u false | c true ) \ facility-ext e-key-to-char
1.12      anton     324:     \G Convert keyboard event @var{u} into character @code{c} if possible.
1.15      pazsan    325:     dup k-left u< ; \ k-left must be first!
1.1       anton     326: 
1.17      anton     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: 
1.12      anton     333: ' key? alias ekey? ( -- flag ) \ facility-ext e-key-question
1.14      anton     334: \G True if a keyboard event is available.
1.1       anton     335: 
1.7       anton     336: \  : esc? ( -- flag ) recursive
                    337: \      key? 0=
                    338: \      if
1.17      anton     339: \       false exit
1.7       anton     340: \      then
                    341: \      key ekey-buffered char-append-buffer
                    342: \      ekey-buffered 2@ esc-sequences search-wordlist
                    343: \      if
1.17      anton     344: \       ['] esc-prefix =
                    345: \       if
                    346: \           esc? exit
                    347: \       then
1.7       anton     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
1.17      anton     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
1.7       anton     364: \      else
1.17      anton     365: \       false
1.7       anton     366: \      then ;
1.1       anton     367: 
1.17      anton     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 ;
1.1       anton     377: \ test-ekey?
1.17      anton     378: [then]

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