\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: kbddi.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: @(#)kbddi.fth 1.8 06/12/15
\ copyright: Copyright 2006 Sun Microsystems, Inc. All Rights Reserved
\ Support for drop in keyboard tables
current-kbd dup c@ if ( addr )
drop " <UNKNOWN>" ( str,len )
2dup >kbd-name ( str,len )
." Keyboard: " type cr ( -- )
h# 20 instance buffer: kbdname
instance variable install-usa?
: get-dropin-info ( kbd-type$ -- false | magic$ dropin$ true )
2dup " sun" $= if 2drop " KBDT" " serialkbds" true exit then
2dup " usb" $= if 2drop " UKBD" " usbkbds" true exit then
: .unsupported-kbd ( -- ) " No keyboard support found" ;
: find-kbd ( addr len -- more? )
install-usa? @ if ( addr )
dup >kbd-country ( addr str )
over >kbd-country-len c@ ( addr str,len )
" US-English" $= ( addr flag? )
dup >kbd-type c@ keybid @ = ( addr flag? )
dup >kbd-coding c@ ( addr coding )
alias-encoding = if ( addr )
>kbd-alias c@ keybid ! ( -- )
dup >kbd-country ( addr str )
over >kbd-country-len c@ ( addr str,len )
: (install-kbd) ( buffer id -- )
['] find-kbd is do-kbd-fn ( buffer id )
>kbd-di-data .scan-kbds ( -- )
: install-usa-maybe ( addr id -- )
found? @ if 2drop exit then
swap 0 ( id addr dummy-id )
." Can't find keyboard table for keyboard layout code " .h cr
." Using USA keyboard table" cr
: install-kbd ( keyboard-type$ layout# -- false | $error true )
install-usa? off ( magic$ dropin$ type )
found? off ( magic$ dropin$ type )
['] noop is base-key-table ( magic$ dropin$ type )
-rot find-drop-in if ( magic$ type addr len )
2dup >r >r drop ( magic$ type addr )
2swap 2 pick >kbd-di-magic 4 $= if ( type addr )
dup >kbd-di-default c@ ( type addr default )
2dup (install-kbd) ( type addr default )
rot ( addr default type )
dup nvram-table? if ( addr default type )
else ( addr default type )
2dup (install-kbd) ( addr type )
r> r> free-drop-in ( -- )
found? @ if false exit then ( -- false )
.unsupported-kbd true ( str,len true )
\ Currently supported list of keyboards. Contains:
\ French, German, Japanese, Spanish, Taiwanese, UK, US
\ See list supported in FWARC 2006/224
\ Note that list of keyboards ids below is in *hex*, while keyboard fcodes
\ are defined with decimal values, so they don't directly match.
\ At some point, this should probably be updated to a list of strings.
: supported-commodity-keyboards ( -- supported-kbd-list supported-kbd-len )
" "(08 09 0f 19 1e 20 21)"
\ Variables used building list of keyboard names.
0 value getbufadr \ This makes code non-reentrant. Sigh.
0 value findbufid \ Returned id
\ Helper function for get-layout-names
\ Copy layout name to buffer. Called from
\ .scan-kbds walking through list.
: store-layout-name ( addr len -- flag )
drop dup >kbd-type c@ ( addr kbd-type )
\ Verify that this keyboard is one of the ones we're allowed to see:
1 swap supported-commodity-keyboards ( addr one kbd-type supported len )
0 do ( addr one kbd-type supported )
2dup i + c@ = if rot drop 0 -rot then \ if permitted, flag permission
loop ( addr flag kbd-type supported )
drop true exit \ This isnt a keyboard we can use.
>kbd-country dup 1- c@ ( addr name-len )
dup getbufused + 1+ to getbufused ( addr name-len )
\ Only store as much string as buffer has room for
drop getbuflen 1- ( addr modified-len )
\ Copy string (or partial string) into target buffer
>r getbufadr r@ move ( r: name-len )
r> dup getbufadr + dup 0 swap c! 1+ ( name-len next-buffer )
to getbufadr ( name-len )
1+ getbuflen swap - to getbuflen true ( true )
\ Coroutine to translate from namestring to dropin address
: find-layout ( addr len -- flag )
drop dup >kbd-country dup 1- c@ ( addr name$ )
findbufadr findbuflen $= ( addr flag )
to findbufid \ Store ID for retrieval
drop true \ Continue search
\ Interface to get list of keyboard layout names. Returns length of
\ strings it wanted to return, which might be longer than the buffer.
: get-layout-names ( buffer length -- length' )
to getbuflen to getbufadr ( )
['] store-layout-name is do-kbd-fn ( )
" usbkbds" " find-drop-in" di-handle $call-method
." Cannot find usbkbds dropin" cr ( )
\ Interface to set the keyboard layout. Returns one of three values:
\ 0 - success. Keyboard layout has been set
\ 1 - failure. No such layout name exists.
\ 2 - failure. Keyboard has hardware identification, cannot set layout.
: set-keyboard-layout ( $name -- flag )
to findbuflen to findbufadr \ Store for use by coroutine
kbd-hard-id if \ Check to see if open found hard-id
2 \ Disallow, report hard-id exists
0 to findbufid \ Preload no id
" usbkbds" " find-drop-in" di-handle $call-method
['] find-layout is do-kbd-fn \ Set coroutine
dup >kbd-country ( addr str )
over >kbd-country-len c@ ( addr str,len )
." Keylayout not found" cr 1 ( flag )
." Cannot find usbkbds dropin" cr 1 ( flag )
projects / OpenSPARC-T2-SAM / blob