\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: tableutil.fth
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ - Do no alter or remove copyright notices
\ - Redistribution and use of this software in source and binary forms, with
\ or without modification, are permitted provided that the following
\ - Redistribution of source code must retain the above copyright notice,
\ this list of conditions and the following disclaimer.
\ - Redistribution in binary form must reproduce the above copyright notice,
\ this list of conditions and the following disclaimer in the
\ documentation and/or other materials provided with the distribution.
\ Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\ This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ ========== Copyright Header End ============================================
\ id: @(#)tableutil.fth 1.2 99/12/01
\ copyright: Copyright 1999 Sun Microsystems, Inc. All Rights Reserved
d# 8192 constant /dropin-buffer
h# 4000 constant /dropin-buffer
/dropin-buffer alloc-mem constant dropin-buffer
variable dropin-insert-ptr
false value writing-tables?
d# 2048 constant /kbddata-buffer
/kbddata-buffer buffer: kbddata-buffer
d# 1024 buffer: base-table
2variable current-table tablename 0 current-table 2!
: >current-table ( adr,len -- )
tablename tuck ( adr buf len buf )
over ( adr buf len buf len )
current-table 2! ( adr buf len )
: current-table$ ( -- adr,len ) current-table 2@ ;
: new-kbd-table ( [alias-id] id encoding -- )
safe-parse-word ( [alias] id encoding adr,len )
2dup >current-table ( [alias] id encoding adr,len )
$create ( [alias] id encoding )
." > Loading " ( [alias] id encoding )
table-encoding of ." full " endof ( [alias] id encoding )
diff-encoding of ." delta " endof ( [alias] id encoding )
alias-encoding of ." alias " endof ( [alias] id encoding )
." Invalid encoding format of " drop ( [alias] id encoding )
endcase ( [alias] id encoding )
." table: " ( [alias] id encoding )
current-table$ type space ( [alias] id encoding )
ascii ( emit ( [alias] id encoding )
base @ >r hex ( [alias] id encoding )
over 2 .r ( [alias] id encoding )
r> base ! ascii ) emit space ( [alias] id encoding )
dup alias-encoding = if ( [alias] id encoding )
." alias" ( [alias] id encoding )
ascii ( emit ( [alias] id encoding )
base @ >r hex ( [alias] id encoding )
2 pick 2 .r ( [alias] id encoding )
r> base ! ascii ) emit space ( [alias] id encoding )
cr ( [alias] id encoding )
then ( [alias] id encoding )
kbddata-buffer 0 /kbd-table-header fill ( [alias] id encoding )
current-table$ ( [alias] id encoding adr,len )
dup kbddata-buffer >kbd-country-len c! ( [alias] id encoding adr len )
kbddata-buffer >kbd-country swap move ( [alias] id encoding )
dup alias-encoding = if ( alias id encoding )
rot ( id encoding alias )
kbddata-buffer tuck ( id encoding buffer alias buffer )
>kbd-alias c! ( id encoding buffer )
dup >kbd-alias-data insert-ptr ! ( id encoding buffer )
kbddata-buffer ( id encoding buffer )
dup >kbd-data insert-ptr ! ( id encoding buffer )
then ( id encoding buffer )
tuck >kbd-coding c! ( id buffer )
: add-kbd-table ( bytes -- )
dup wbsplit ( bytes lo hi )
kbddata-buffer >kbd-data-size tuck ( bytes lo addr hi addr )
kbddata-buffer over ( bytes addr bytes )
dropin-insert-ptr @ ( bytes addr bytes dest )
dropin-insert-ptr +! ( -- )
writing-tables? ( writing? )
kbddata-buffer >kbd-coding c@ ( writing? encoding )
table-encoding = and if ( -- )
dropin-buffer >kbd-di-default c@ h# ff if
\ We haven't assigned a default keybd yet
kbddata-buffer >kbd-type c@
dropin-buffer >kbd-di-default c!
: list-kbd ( addr len -- true )
dup >kbd-country ( addr len addr adr )
swap >kbd-country-len c@ ( addr len adr,len )
." Name: " type ( addr len )
over >kbd-type c@ ." , id: " .x ( addr len )
over >kbd-coding c@ ( addr len encoding )
dup table-encoding = if ( addr len )
drop ." table" ( addr len )
diff-encoding = if ( addr len )
['] list-kbd is do-kbd-fn ( -- )
dropin-buffer 5 + ( addr )
: find-default-kbd ( adr len -- ok? )
over >kbd-type c@ ( adr len id )
dropin-buffer >kbd-di-default c@ <> ( adr len flag? )
." Default Keyboard is: " ( flag? adr )
dup >kbd-country ( flag? adr str )
over >kbd-country-len c@ ( flag? adr str len )
: write-kbd-dropin ( -- )
dropin-insert-ptr @ ( adr ptr )
h# ff over c! ( adr ptr )
1+ h# ff over c! ( adr ptr' )
over >kbd-di-default c@ h# ff = if ( adr ptr' )
." No Default keyboard found" cr
." This probably means that there isn't a full table defined" cr
['] find-default-kbd is do-kbd-fn ( adr ptr' )
over >kbd-di-data .scan-kbds ( adr ptr' )
[ifdef] list-kbds? ( adr ptr' )
: savechar ( char -- ) kbd-char-ptr @ c! 1 kbd-char-ptr +! ;
defer delta-debug ' drop is delta-debug
defer table-debug ' noop is table-debug
defer build-table [ifdef] verbose? ' cr [else] ' noop [then] is build-table
fload ${BP}/pkg/keyboard/debug.fth
variable total-bytes total-bytes off
: build-dropin-table ( -- )
current-table 2@ $find if
." Table Constructed improperly!" abort
diff-encoding kbddata-buffer >kbd-coding c! ( -- )
insert-ptr @ holding-ptr ! ( -- )
insert-ptr @ kbd-char-ptr ! ( -- )
key-table >k-altgmap i + c@ ( 0 keycode )
base-table >k-altgmap i + c@ over <> if ( 0 keycode )
key-table >k-shiftmap i + c@ ( flag keycode )
base-table >k-shiftmap i + c@ over <> if ( flag keycode )
key-table >k-normalmap i + c@ ( keycode )
base-table >k-normalmap i + c@ over <> if ( keycode )
kbd-char-ptr @ insert-ptr ! ( -- )
num-deltas dup @ 1+ swap ! ( -- )
insert-ptr @ kbd-char-ptr ! ( -- )
h# ff savechar kbd-char-ptr @ insert-ptr ! ( -- )
[ifdef] verbose? dup if ." , " dup .d ." diffs" then [then]
dup 0= swap d# 96 > or if ( -- )
\ If we have more than 96 diffs then it is more
\ space efficient to change the table back to a
[ifdef] verbose? ." , table-encoding" [then]
table-encoding kbddata-buffer >kbd-coding c! ( -- )
key-table holding-ptr @ /keytable move ( -- )
holding-ptr @ /keytable + insert-ptr ! ( -- )
insert-ptr @ kbddata-buffer - ( bytes )
[ifdef] verbose? ." , " dup .d ." bytes" cr [then] ( bytes )
total-bytes @ over + total-bytes ! ( bytes )
current-table 2@ $find if
." Table Constructed improperly!" abort
insert-ptr @ kbd-char-ptr ! ( -- )
h# ff savechar kbd-char-ptr @ insert-ptr ! ( -- )
insert-ptr @ kbddata-buffer - ( bytes )
total-bytes @ over + total-bytes ! ( bytes )
." Keyboard data = " total-bytes @ .d ." bytes" cr
fload ${BP}/pkg/keyboard/tablecode.fth
: >base-table ( addr -- ) base-table /keytable move ;
: >base-table ( addr -- ) drop ;
: build-empty-table ( -- ) base-table 0 /keytable fill ;
projects / OpenSPARC-T2-SAM / blob