[commit] r2440 - cpu/x86/pc/alex

[repository service]

Author: lwalter
Date: Tue Aug  9 20:23:46 2011
New Revision: 2440
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2440

Log:
Add mfgtest support

Added:
   cpu/x86/pc/alex/kbdtest.fth

Added: cpu/x86/pc/alex/kbdtest.fth
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ cpu/x86/pc/alex/kbdtest.fth	Tue Aug  9 20:23:46 2011	(r2440)
@@ -0,0 +1,641 @@
+purpose: Interactive keyboard test shows which keys are pressed
+\ See license at end of file
+
+\needs final-test?  0 value final-test?
+\needs smt-test?    0 value smt-test?
+
+dev /keyboard
+hex
+
+\ This is 1 for the Alex keyboard and 2 for the AT keyboard.
+1 value keyboard-type
+
+\ There are two scancode tables:
+\   1.  simple scancode (down values); up value is f0 + scancode
+\   2.  e0 + scancode (down values);   up value is e0 + f0 + scancode
+\ For each scancode: index into keys
+
+\ For each key: x, y, w, h
+\   where x, y, w, h are parameters for painting the key
+
+struct
+   /n field >key-x
+   /n field >key-y
+   /n field >key-w
+   /n field >key-h
+   /n field >key-time
+constant /key
+
+/key d# 128 * buffer: keys
+
+0 value #keys
+0 value key-y
+0 value key-x
+
+\ Based on 1280*800 screen resolution
+
+d#  10 constant key-gap
+d#  12 constant row-gap
+d#   0 constant hidden-key-w
+d#  70 constant smulti-key-w
+d#  70 constant single-key-w
+d#  70 constant single-key-h
+d#  45 constant squat-key-h
+d#  33 constant half-key-h
+d#   4 constant half-key-gap
+d# 105 constant shift-key-w
+d# 540 constant space-key-w
+d# 300 constant top-row-offset
+
+: key-adr  ( i -- adr )  /key * keys +  ;
+: top-key-row  ( -- )  top-row-offset to key-y  key-gap to key-x  ;
+: next-key-row  ( -- )
+   key-y single-key-h + row-gap + to key-y
+   key-gap to key-x 
+;
+: next-squat-row  ( -- )
+   key-y squat-key-h + row-gap + to key-y
+   key-gap to key-x 
+;
+: #keys++  ( -- )  #keys 1+ to #keys  ;
+: ++key-x  ( n -- )  key-x + to key-x  ;
+: add-key-gap  ( -- )  key-gap ++key-x  ;
+: (make-key)  ( x y w h -- )
+   #keys key-adr >r
+   r@ >key-h ! r@ >key-w !  r@ >key-y !  r@ >key-x !
+   0 r> >key-time !
+   #keys++
+;
+: make-key  ( w -- )  dup key-x key-y rot single-key-h (make-key) ++key-x  ;
+: make-key&gap  ( w -- )  make-key add-key-gap  ;
+: make-squat-key&gap  ( w -- )  dup key-x key-y rot squat-key-h (make-key) ++key-x  add-key-gap  ;
+: make-single-key  ( -- )  single-key-w make-key&gap  ;
+: make-smulti-key  ( i -- )
+   1 and  if
+      hidden-key-w make-key
+   else
+      smulti-key-w make-key
+   then
+;
+: make-double-key  ( -- )  single-key-w 2* make-key&gap  ;
+: make-shift-key   ( -- )  shift-key-w make-key&gap  ;
+: make-space-key   ( -- )  space-key-w make-key&gap  ;
+: make-quad-key    ( -- )
+   key-x key-y single-key-w 2* dup >r single-key-h 2* row-gap + (make-key)
+   r> ++key-x
+   add-key-gap
+;
+: make-narrower-key  ( -- )  d#  60 make-key&gap  ;
+: make-std-key       ( -- )  d#  78 make-key&gap  ;
+: make-wider-key     ( -- )  d# 120 make-key&gap  ;
+: make-wider-key1    ( -- )  d# 143 make-key&gap  ;
+: make-wider-key2    ( -- )  d# 165 make-key&gap  ;
+: make-wider-key3    ( -- )  d# 187 make-key&gap  ;
+: make-squat-key     ( -- )  d#  96 make-squat-key&gap  ;
+: make-space-bar     ( -- )  d# 440 make-key&gap  ;
+: make-top-half  ( -- )  
+   d# 70 key-x key-y rot half-key-h (make-key)
+;
+: make-bottom-half&gap  ( -- )
+   d# 70 dup
+   key-x key-y half-key-h + half-key-gap + rot half-key-h (make-key)
+   ++key-x add-key-gap
+;
+
+: make-keys1  ( -- )
+   0 to #keys
+   top-key-row
+   d# 11 0  do  make-squat-key  loop  \ esc, f1-f10, hole for power
+
+   next-squat-row
+   d# 13 0  do  make-std-key  loop      \ ` 1-0 -=
+   make-wider-key   \ bksp
+
+   next-key-row
+   make-wider-key   \ tab
+   d# 13 0  do  make-std-key  loop      \ Q-P []\
+
+   next-key-row
+   make-wider-key1  \ Win L
+   d# 11 0  do  make-std-key  loop      \ A-L ;'
+   make-wider-key1  \ enter
+
+   next-key-row
+   make-wider-key3  \ lshift
+   d# 10 0  do  make-std-key  loop      \ Z-M ,./
+   make-wider-key3  \ rshift
+
+   next-key-row
+   d# 2 0  do  make-wider-key2  loop   \ lctrl lalt
+   make-space-bar  \ space
+   make-wider-key       \ ralt
+   d# 2 0  do  make-std-key  loop          \ rctrl <
+   make-top-half                     \ ^
+   make-bottom-half&gap              \ v
+   make-std-key                            \ >
+;
+: make-keys2  ( -- )
+   0 to #keys
+   top-key-row
+   make-std-key     \ esc
+   d# 88 ++key-x
+   4 0  do  make-std-key  loop  \ F1-F4
+   d# 21 ++key-x
+   4 0  do  make-std-key  loop  \ F5-F8
+   d# 21 ++key-x
+   4 0  do  make-std-key  loop  \ F9-F12
+
+   next-key-row
+   d# 13 0  do  make-std-key  loop      \ ` 1-0 -=
+   make-wider-key   \ bksp
+
+   next-key-row
+   make-wider-key   \ tab
+   d# 13 0  do  make-std-key  loop      \ Q-P []\
+
+   next-key-row
+   make-wider-key1  \ capslock
+   d# 11 0  do  make-std-key  loop      \ A-L ;'
+   make-wider-key1  \ enter
+
+   next-key-row
+   make-wider-key3  \ lshift
+   d# 10 0  do  make-std-key  loop      \ Z-M ,./
+   make-wider-key3  \ rshift
+
+   next-key-row
+   d# 2 0  do  make-wider-key1  loop   \ lctrl lalt
+   d# 652 make-key&gap  \ space
+   d# 2 0  do  make-wider-key1  loop   \ ralt rctrl
+;
+
+0 [if]
+hex
+\ This is indexed by the IBM key number (the physical key number as
+\ shown on language-independent drawings of the keyboard layout since
+\ the original IBM documentation).  The values are scanset1 codes.
+create (ibm#>scan1)
+\   0     1     3     3     4     5     6     7     8     9
+   00 c, 29 c, 02 c, 03 c, 04 c, 05 c, 06 c, 07 c, 08 c, 09 c,  \   
+   0a c, 0b c, 0c c, 0d c, 00 c, 0e c, 0f c, 10 c, 11 c, 12 c,  \ 1x
+   13 c, 14 c, 15 c, 16 c, 17 c, 18 c, 19 c, 1a c, 1b c, 2b c,  \ 2x
+   3a c, 1e c, 1f c, 20 c, 21 c, 22 c, 23 c, 24 c, 25 c, 26 c,  \ 3x
+   27 c, 28 c, 00 c, 1c c, 2a c, 56 c, 2c c, 2d c, 2e c, 2f c,  \ 4x
+   30 c, 31 c, 32 c, 33 c, 34 c, 35 c, 73 c, 36 c, 1d c, 00 c,  \ 5x
+   38 c, 39 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,  \ 6x
+   00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,  \ 7x
+   00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,  \ 8x
+   45 c, 47 c, 4B c, 4F c, 00 c, 00 c, 48 c, 4C c, 50 c, 52 c,  \ 9x
+   37 c, 49 c, 4D c, 51 c, 53 c, 4A c, 4E c, 00 c, 1c c, 00 c,  \ 1   
+   01 c, 00 c, 3b c, 3c c, 3d c, 3e c, 3f c, 40 c, 41 c, 42 c,  \ 11x
+   43 c, 44 c, 57 c, 58 c, 00 c, 46 c, 00 c, 00 c, 00 c, 00 c,  \ 12x
+   79 c, 00 c, 00 c, 5c c, 73 c, 6e c, 00 c, 00 c, 00 c, 00 c,  \ 13x (analog intermediates)
+   00 c, 00 c, 00 c, 00 c, 00 c,                                \ 14x
+
+\ A program to invert the table above.  We used the inverted form.
+h# 80 buffer: sc1
+: invert-ibm  ( -- )
+   sc1 h# 80 erase
+   d# 145 0 do
+     (ibm#>scan1) i + c@  ?dup  if  i  swap sc1 +  c!  then
+   loop
+
+   h# 80 0 do
+      ." ( " i 2 u.r ."  ) "
+      i 8 bounds do
+         sc1 i + c@ push-decimal 3 u.r pop-base  ."  c, "
+      loop
+      cr
+   8 +loop
+;
+[then]
+
+0 value key-stuck?
+
+d# 128 8 / constant #key-bytes
+#key-bytes buffer: key-bitmap
+: set-key-bit  ( key# -- )
+   8 /mod           ( bit# byte# )
+   key-bitmap +     ( bit# adr )
+   tuck c@          ( adr bit# old-byte )
+   1 rot lshift or  ( adr byte )
+   swap c!
+;
+-1 value last-1
+-1 value last-2
+: clear-key-bitmap  ( -- )
+   key-bitmap #key-bytes erase
+   -1 to last-1   -1 to last-2
+;
+
+0 [if]
+\ Funny-map1 has bits clear at the locations of intermediate
+\ slider keys.  Those keys are only active by pressing the fn
+\ key, and need not be tested during operator finger-sweeps of the
+\ keyboard.  It is okay if the operator tests them, so we mask
+\ off those bits if they happen to be set in the bitmap.
+h# ffd5ab57 constant funny-map1
+
+create all-keys-bitmap1
+57 c, ab c, d5 c, ff c, ff c, ff c, ff c, ff c,  \ Omits the intermediate slider keys
+ff c, ff c, ff c, ff c, 03 c, 00 c, 00 c, 00 c,
+[else]
+\ The mechanical keyboard has no slider keys. All displayed button locations are
+\ activated by pressing single keystrokes, so the map is dense
+h# ffffffff constant funny-map1
+create all-keys-bitmap1
+ff c, ff c, ff c, ff c, ff c, ff c, ff c, ff c,
+ff c, ff c, 3f c, 00 c, 00 c, 00 c, 00 c, 00 c,
+[then]
+
+\ The mechanical keyboard has no slider keys. All displayed button locations are
+\ activated by pressing single keystrokes, so the map is dense
+h# ffffffff constant funny-map2
+create all-keys-bitmap2
+ff c, ff c, ff c, ff c, ff c, ff c, ff c, ff c,
+ff c, ff c, 3f c, 00 c, 00 c, 00 c, 00 c, 00 c,
+
+: all-tested?1  ( -- flag )
+   key-bitmap @ funny-map1 and key-bitmap !
+   key-bitmap  all-keys-bitmap1  #key-bytes comp 0=
+;
+: all-tested?2  ( -- flag )
+   key-bitmap @ funny-map2 and key-bitmap !
+   key-bitmap  all-keys-bitmap2  #key-bytes comp 0=
+;
+defer all-tested?
+
+\ This table is indexed by the (unescaped) scanset1 code, giving
+\ an IBM physical key number.
+
+decimal
+create (scan1>ibm#)
+\      0/8    1/9    2/a    3/b    4/c    5/d    6/e    7/f
+(  0 )   0 c, 110 c,   2 c,   3 c,   4 c,   5 c,   6 c,   7 c,  \ 01 is esc
+(  8 )   8 c,   9 c,  10 c,  11 c,  12 c,  13 c,  15 c,  16 c,
+( 10 )  17 c,  18 c,  19 c,  20 c,  21 c,  22 c,  23 c,  24 c,
+( 18 )  25 c,  26 c,  27 c,  28 c,  43 c,  58 c,  31 c,  32 c,  \ 1d is ctrl, 1c is Enter
+( 20 )  33 c,  34 c,  35 c,  36 c,  37 c,  38 c,  39 c,  40 c,
+( 28 )  41 c,   1 c,  44 c,  29 c,  46 c,  47 c,  48 c,  49 c,
+( 30 )  50 c,  51 c,  52 c,  53 c,  54 c,  55 c,  57 c, 100 c,
+( 38 )  60 c,  61 c,  30 c, 112 c, 113 c, 114 c, 115 c, 116 c,
+( 40 ) 117 c, 118 c, 119 c, 120 c, 121 c,  90 c, 125 c,  91 c,
+( 48 )  96 c, 101 c, 105 c,  92 c,  97 c, 102 c, 106 c,  93 c,
+( 50 )  98 c, 103 c,  99 c, 104 c,   0 c,   0 c,  45 c, 122 c,
+( 58 ) 123 c,  59 c,   0 c,   0 c, 133 c,   0 c,   0 c,   0 c,  \ scan h# 59 is Fn - ibm# d# 59
+( 60 )   0 c,   0 c,   0 c,   0 c,   0 c, 150 c, 153 c, 151 c,  \ 66-68 are left rocker
+( 68 ) 152 c, 154 c,   0 c,   0 c,   0 c,   0 c, 135 c,   0 c,  \ 69 is rotate
+( 70 )   0 c,   0 c,   0 c,  56 c,   0 c,   0 c,   0 c,   0 c,
+( 78 )   0 c, 130 c,   0 c,   0 c,   0 c,   0 c,   0 c,   0 c,
+hex
+
+\ This should be a lookup table.  It would be smaller that way
+: e0-scan1>ibm#  ( scancode -- ibm# )
+   case
+      h# 38 of  d# 62  endof  \ R ALT
+
+\ For a standard PC keyboard
+( \ ) h# 1c of  d# 64  endof  \ Numeric enter
+( \ ) h# 1d of  d# 64  endof  \ R CTRL
+      h# 52 of  d# 75  endof  \ Insert
+      h# 53 of  d# 76  endof  \ Delete
+( \ ) h# 47 of  d# 80  endof  \ Home
+( \ ) h# 4f of  d# 81  endof  \ End
+( \ ) h# 49 of  d# 85  endof  \ PageUp
+( \ ) h# 51 of  d# 86  endof  \ PageDown
+
+      h# 3b of  d# 112 endof  \ Fn 1
+      h# 3c of  d# 113 endof  \ Fn 2
+      h# 3d of  d# 114 endof  \ Fn 3
+      h# 3e of  d# 115 endof  \ Fn 4
+      h# 3f of  d# 116 endof  \ Fn 5
+      h# 40 of  d# 117 endof  \ Fn 6
+      h# 41 of  d# 118 endof  \ Fn 7
+      h# 42 of  d# 119 endof  \ Fn 8
+      h# 43 of  d# 120 endof  \ Fn 9
+      h# 44 of  d# 121 endof  \ Fn 10
+      h# 57 of  d# 122 endof  \ Fn 11
+      h# 58 of  d# 123 endof  \ Fn 12
+
+      h# 4b of  d# 79  endof  \ Left Arrow
+      h# 48 of  d# 83  endof  \ Up Arrow
+      h# 50 of  d# 84  endof  \ Down Arrow
+      h# 4d of  d# 89  endof  \ Right Arrow
+
+      h# 5b of  d# 131  endof  \ Win L
+   endcase
+;
+
+: scan1>ibm#  ( scancode1 esc? -- ibm# )
+   if  e0-scan1>ibm#  else  (scan1>ibm#) + c@  then
+;
+
+\ "key#" is a physical location on the screen
+\ "ibm#" is the key number as shown on the original IBM PC documents
+decimal
+
+create ibm#s1
+   \ Top row, key#s 0x00-0x18
+   110 c,                                            \ ESC
+   112 c, 113 c, 114 c, 115 c, 116 c, 117 c,         \ F1-F6
+   118 c, 119 c, 120 c, 121 c,                       \ F7-F10
+
+   \ Number row - `1234567890-= BS
+   1 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, 8 c, 9 c, 10 c, 11 c, 12 c, 13 c, 15 c,
+
+   \ Top alpha row - tab QWERTYUIOP []\
+   16 c, 17 c, 18 c, 19 c, 20 c, 21 c, 22 c, 23 c, 24 c, 25 c, 26 c, 27 c, 28 c, 29 c,
+
+   \ Middle alpha row - win ASDFGHIJKL ;' enter
+   131 c, 31 c, 32 c, 33 c, 34 c, 35 c, 36 c, 37 c, 38 c, 39 c, 40 c, 41 c, 43 c,
+
+   \ Bottom alpha row - shift ZXCVBNM , . / shift
+   44 c, 46 c, 47 c, 48 c, 49 c, 50 c, 51 c, 52 c, 53 c, 54 c, 55 c, 57 c,
+
+   \ Function row - ctrl alt space alt ctrl < ^v >
+   58 c, 60 c, 61 c, 62 c, 64 c, 79 c, 83 c, 84 c, 89 c,
+
+here ibm#s1 - constant /ibm#s1
+
+\ "key#" is a physical location on the screen
+\ "ibm#" is the key number as shown on the original IBM PC documents
+\ The actual #s for F6 and F7 are 146 and 147, but the EC does some magic
+create ibm#s2
+   \ Top row, key#s 0x00-0x18
+   110 c,                                            \ ESC
+   112 c, 113 c, 114 c, 115 c, 116 c, 117 c,         \ F1-F6
+   118 c, 119 c, 120 c, 121 c, 122 c, 123 c,         \ F7-F12
+\  148 c, 149 c,                                     \ ins, del
+\    75 c,  76 c,                                     \ ins, del
+
+   \ Number row - `1234567890-= BS
+   1 c, 2 c, 3 c, 4 c, 5 c, 6 c, 7 c, 8 c, 9 c, 10 c, 11 c, 12 c, 13 c, 15 c,  \ 1 is really 150
+
+   \ Top alpha row - tab QWERTYUIOP []\
+   16 c, 17 c, 18 c, 19 c, 20 c, 21 c, 22 c, 23 c, 24 c, 25 c, 26 c, 27 c, 28 c, 29 c, \ 28 is really 151
+
+   \ Middle alpha row - capslock ASDFGHIJKL ;' enter
+   30 c, 31 c, 32 c, 33 c, 34 c, 35 c, 36 c, 37 c, 38 c, 39 c, 40 c, 41 c, 43 c,
+
+   \ Bottom alpha row - shift ZXCVBNM , . / shift
+   44 c, 46 c, 47 c, 48 c, 49 c, 50 c, 51 c, 52 c, 53 c, 54 c, 55 c, 57 c,
+
+   \ Function row - ctrl alt space alt ctrl
+   58 c, 60 c, 61 c, 62 c, 64 c,
+
+here ibm#s2 - constant /ibm#s2
+hex
+
+defer make-keys  ( -- )
+defer ibm#s      ( -- adr )
+defer /ibm#s     ( -- n )
+
+: ibm#>key#  ( ibm# -- true | key# false )
+   /ibm#s 0  ?do   ( ibm# )
+      dup  ibm#s i + c@   =  if
+         drop i false unloop exit
+      then
+   loop                      ( ibm# )
+   drop true
+;
+
+0 [if]
+\ This is a program to invert the ibm#s table
+d# 145 buffer: sc2
+: invert-key  ( -- )
+   sc2 d# 145 erase
+   h# 59 0 do
+     i  ibm#s i + c@  sc2 +  c!
+   loop
+
+   d# 145 0 do
+      ." ( " i  push-decimal  3 u.r  pop-base  ."  ) "
+      i d# 10 bounds do
+         sc2 i + c@ push-hex  2 u.r    pop-base  ."  c, "
+      loop
+      cr
+   d# 10 +loop
+;
+[then]
+
+0 [if]
+\ These are maps from scanset 2 to key position numbers.
+\ They are no longer used
+hex
+create raw-scancode
+   ( -0 )  -1 c, 10 c, 0d c, 09 c, 06 c, 02 c, 04 c, 16 c,
+   ( 08 )  -1 c, 12 c, 0f c, 0b c, 08 c, 27 c, 19 c, 50 c,
+   ( 10 )  -1 c, 52 c, 42 c, -1 c, 35 c, 28 c, 1a c, -1 c,
+   ( 18 )  -1 c, -1 c, 43 c, 37 c, 36 c, 29 c, 1b c, -1 c,
+   ( 20 )  -1 c, 45 c, 44 c, 38 c, 2a c, 1d c, 1c c, -1 c,
+   ( 28 )  -1 c, 53 c, 46 c, 39 c, 2c c, 2b c, 1e c, -1 c,
+   ( 30 )  -1 c, 48 c, 47 c, 3b c, 3a c, 2d c, 1f c, -1 c,
+   ( 38 )  -1 c, -1 c, 49 c, 3c c, 2e c, 20 c, 21 c, -1 c,
+   ( 40 )  -1 c, 4a c, 3d c, 2f c, 30 c, 23 c, 22 c, -1 c,
+   ( 48 )  -1 c, 4b c, 4c c, 3e c, 3f c, 31 c, 24 c, -1 c,
+   ( 50 )  -1 c, 4f c, 40 c, -1 c, 32 c, 25 c, -1 c, -1 c,
+   ( 58 )  -1 c, 4d c, 34 c, 33 c, -1 c, 41 c, -1 c, -1 c,
+   ( 60 )  -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, 26 c, -1 c,
+   ( 68 )  -1 c, -1 c, -1 c, -1 c, -1 c, 4f c, -1 c, -1 c,
+   ( 70 )  -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, 00 c, -1 c,
+   ( 78 )  14 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c,
+
+create e0-scancode
+   ( 00 )  -1 c, 10 c, 0d c, 09 c, 06 c, 02 c, 04 c, 16 c,
+   ( 08 )  17 c, 12 c, 0f c, 0b c, 08 c, -1 c, -1 c, -1 c,
+   ( 10 )  -1 c, 54 c, -1 c, 13 c, -1 c, -1 c, -1 c, 18 c,
+   ( 18 )  -1 c, 11 c, -1 c, -1 c, -1 c, -1 c, -1 c, 51 c,
+   ( 20 )  -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, 55 c,
+   ( 28 )  -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, 18 c,
+   ( 30 )  -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c,
+   ( 38 )  -1 c, 0e c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c,
+   ( 40 )  -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c,
+   ( 48 )  -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c, -1 c,
+   ( 50 )  -1 c, 0c c, -1 c, 0a c, -1 c, -1 c, -1 c, 17 c,
+   ( 58 )  -1 c, -1 c, -1 c, -1 c, 07 c, -1 c, -1 c, 05 c,
+   ( 60 )  -1 c, 53 c, 03 c, 01 c, 01 c, -1 c, -1 c, -1 c,
+   ( 68 )  -1 c, 58 c, -1 c, 56 c, 56 c, -1 c, -1 c, 15 c,
+   ( 70 )  4d c, 26 c, 57 c, -1 c, 58 c, 4e c, 00 c, -1 c,
+   ( 78 )  14 c, -1 c, 57 c, -1 c, -1 c, 4e c, -1 c, -1 c,
+
+raw-scancode value cur-sc-table
+[then]
+
+h# f81f constant down-key-color
+h# 07ff constant tested-key-color
+h# 001f constant idle-key-color
+h# ffff constant kbd-bc
+
+0 value esc?
+
+: scan1->key#  ( scancode -- true | key# false )
+   esc?  scan1>ibm#  
+   ?dup 0=  if  true exit  then
+   ibm#>key#
+;
+
+: set-key-time  ( timestamp key-adr -- )
+   over 0<>  over >key-time @  0<>  and   if  ( timestamp key-adr )
+      \ If both timestamp and old key time are nonzero, then we preserve the old key time
+      >key-time @  d# 3,000 +  -  0>  to key-stuck?
+   else
+      \ If either timestamp or old key time is 0, we set the key time
+      >key-time !
+   then
+;
+
+: draw-key  ( key# color timestamp  -- )
+   rot key-adr >r          ( color# timestamp r: key-adr )
+   r@ set-key-time         ( color#           r: key-adr )
+   r@ >key-w @  hidden-key-w  =  if  ( color# r: key-adr )
+      r> 2drop                       ( )
+   else                              ( color# r: key-adr )
+      r@ >key-x @  r@ >key-y @  r@ >key-w @  r> >key-h @  ( color# x y w h )
+      " fill-rectangle" $call-screen   ( )
+   then
+;
+: key-tested ( key# -- )  tested-key-color 0          draw-key  ;
+: key-down   ( key# -- )  down-key-color   get-msecs  draw-key  ;
+: key-up     ( key# -- )  idle-key-color   0          draw-key  ;
+
+: fill-screen  ( color -- )
+   0 0 " dimensions" $call-screen " fill-rectangle" $call-screen
+;
+
+: draw-keyboard  ( -- )
+   kbd-bc fill-screen
+   #keys 0  ?do  i key-up  loop
+\   final-test?  smt-test?  or  0=  if  0 d# 13 at-xy ." X"  then
+;
+
+false value verbose?
+
+: process-raw  ( scan-code -- exit? )
+   verbose?  if  dup u.  then
+   dup h# e0 =  if                           ( scan )
+      drop  true to esc?                     ( )
+   else                                      ( scan )
+      dup h# 7f and scan1->key#  if          ( scan )
+         drop                                ( )
+      else                                   ( scan key# )
+         swap h# 80 and  if   \ Up           ( key# )
+            final-test?  smt-test?  or  if   ( key# )
+               dup key-tested                ( key# )
+               dup 0=  last-1 0= and  last-2 0=  and  if   ( key# )
+                  drop true                  ( exit? )
+               else                          ( key# )
+                  last-1 to last-2  to last-1  ( )
+                  all-tested?                ( exit? )
+               then
+            else                             ( key# )
+               dup key-up                    ( key# )
+               \ 0 is the ESC key
+               0=                            ( exit? )
+            then                             ( exit? )
+            if  true exit  then              ( )
+         else                                ( key# )
+            dup set-key-bit                  ( key# )
+            key-down                         ( )
+         then                                ( )
+      then                                   ( )
+      false to esc?                          ( )
+   then                                      ( )
+   false
+;
+
+0 value last-timestamp
+: selftest-keys  ( -- )
+   false to esc?
+   clear-key-bitmap
+   get-msecs to last-timestamp
+   begin
+      final-test?  smt-test?  or  if
+         key-stuck?  if  exit  then
+      then
+      get-data?  if                  ( scancode )
+         process-raw                 ( exit? )
+         get-msecs to last-timestamp
+      else
+         final-test?  smt-test?  or  if
+            false   \ Final test exit inside process-raw
+         else
+\            get-msecs last-timestamp -  d# 100,000 >=
+false
+         then
+      then             ( exit? )
+   until
+   begin  get-data?  while  drop  repeat
+;
+
+: toss-keys  ( -- )  begin  key?  while  key drop  repeat  ;
+
+: set-keyboard-type  ( -- )
+   keyboard-type  case
+      1 of  ['] make-keys1    ['] ibm#s1  ['] /ibm#s1  ['] all-tested?1  endof
+      2 of  ['] make-keys2    ['] ibm#s2  ['] /ibm#s2  ['] all-tested?2  endof
+      ( default )  true abort" Unknown keyboard type"
+   endcase
+   to all-tested?  to /ibm#s  to ibm#s  to make-keys
+;
+
+warning @ warning off
+: selftest  ( -- error? )
+   open  0=  if  true exit  then
+
+   set-keyboard-type
+
+   make-keys
+
+   0 to key-stuck?
+   cursor-off draw-keyboard
+   true to locked?   \ Disable the keyboard alarm handler; it steals our scancodes
+   selftest-keys
+   false to locked?
+   cursor-on
+   screen-ih iselect  erase-screen  iunselect
+   page
+   close
+
+   final-test? smt-test? or  if
+      key-stuck?  if
+         ." Stuck key" cr
+         true exit
+      then
+
+      all-tested?  if
+         false
+      else
+         ." Some keys were not pressed" cr
+         true
+      then
+   else
+      confirm-selftest?
+   then
+;
+warning !
+
+device-end
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2007 FirmWorks
+\ 
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\ 
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\ 
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END