[OpenSPARC-T2-SAM] / obp / obp / pkg / keyboard / translator / kbddi.fth

\ ========== 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 
\    conditions are met: 
\ 
\  - 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
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
\ id: @(#)kbddi.fth 1.8 06/12/15
\ purpose: 
\ copyright: Copyright 2006 Sun Microsystems, Inc.  All Rights Reserved
\
\ Support for drop in keyboard tables
\ 

headers

: current ( -- )
  current-kbd dup c@ if		( addr )
    dup cstrlen			( str,len )
  else				( addr )
    drop " <UNKNOWN>"		( str,len )
    2dup >kbd-name		( str,len )
  then				( str,len )
  ." Keyboard: " type cr	( -- )
;

headerless

h# 20 instance buffer: kbdname
0 value kbd-hard-id

instance variable found?
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 	   
  2drop false
;

: .unsupported-kbd ( -- ) " No keyboard support found" ;

: find-kbd ( addr len -- more? )
   drop					( addr )
   install-usa? @  if			( addr )
      dup >kbd-country 			( addr str )
      over >kbd-country-len c@ 		( addr str,len )
      " US-English" $= 			( addr flag? ) 
   else 				( addr )
      dup >kbd-type c@ keybid @ = 	( addr flag? )
   then					( addr flag? )
   dup found? ! if			( addr )
     dup >kbd-coding c@  		( addr coding )
     alias-encoding =  if 		( addr )
        >kbd-alias c@ keybid !    	( -- ) 
        found? off			( -- )
        restart-scan? on		( -- )
     else				( addr )
        dup >kbd-country		( addr str )
        over >kbd-country-len c@	( addr str,len )
        >kbd-name			( addr )
        >kbd-type			( addr' )
        set-keytable			( -- )
     then				( -- )
   else					( addr )
     drop				( -- )
   then					( -- )
   found? @ 0=				( flag? )
;

: (install-kbd) ( buffer id -- )
  ['] find-kbd is do-kbd-fn	( buffer id )
  keybid !			( buffer )
  >kbd-di-data .scan-kbds	( -- )
;

: install-usa-maybe  ( addr id -- )
  found? @ if 2drop exit then

  install-usa? on
  swap 0		( id addr dummy-id )
  (install-kbd)		( id )
  found? @ if		( id )
    ." Can't find keyboard table for keyboard layout code " .h cr
    ." Using USA keyboard table" cr
  else
    drop
  then
;

headers
: 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 )
         3drop		 		( -- )
       else				( addr default type )
         tuck <> if			( addr type )
           2dup (install-kbd)		( addr type )
           install-usa-maybe		( -- )
         else				( addr type )
           2drop			( -- )
         then				( -- )
       then				( -- )
     else				( type' addr )
       2drop				( -- )
     then				( -- )
     r> r> free-drop-in			( -- )
  else					( type' )
    drop				( -- )
  then					( -- )
  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)"
;

headerless
\ Variables used building list of keyboard names.

0 value getbufadr	\ This makes code non-reentrant. Sigh.
0 value getbuflen
0 value getbufused
0 value findbufadr
0 value findbuflen
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 )
  2drop if 
     drop true exit			\ This isnt a keyboard we can use.
  then

  >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
  dup getbuflen >= if
    drop getbuflen 1-		 	( addr modified-len )
  then					( addr name-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 )
  if
    to findbufid			\ Store ID for retrieval
    false				\ End search
  else
    drop true				\ Continue search
  then
;

external
\ 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	 	( )
   0 to getbufused			( )
   ['] store-layout-name is do-kbd-fn	( )
   " usbkbds" " find-drop-in" di-handle $call-method
					( usbkbds len flag )
   if
     drop 5 + .scan-kbds		( )
   else
     ." Cannot find usbkbds dropin" cr	( )
   then					( )
   getbufused				( length' )
;


\ 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
  else
    0 to findbufid			\ Preload no id

    " usbkbds" " find-drop-in" di-handle $call-method
					( usbkbds len flag )
    if
      ['] find-layout is do-kbd-fn	\ Set coroutine
      drop 5 + .scan-kbds		( )
      findbufid if
        findbufid			( addr )
        dup >kbd-country		( addr str )
        over >kbd-country-len c@	( addr str,len )
        >kbd-name			( addr )
        >kbd-type			( addr' )
        set-keytable			( -- )
	0				( flag )
      else
        ." Keylayout not found" cr 1	( flag )
      then
    else
      ." Cannot find usbkbds dropin" cr 1 ( flag )
    then				( flag )
  then
;


headers
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: kbddi.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	\ id: @(#)kbddi.fth 1.8 06/12/15
	43	\ purpose:
	44	\ copyright: Copyright 2006 Sun Microsystems, Inc. All Rights Reserved
	45	\
	46	\ Support for drop in keyboard tables
	47	\
	48
	49	headers
	50
	51	: current ( -- )
	52	current-kbd dup c@ if ( addr )
	53	dup cstrlen ( str,len )
	54	else ( addr )
	55	drop " <UNKNOWN>" ( str,len )
	56	2dup >kbd-name ( str,len )
	57	then ( str,len )
	58	." Keyboard: " type cr ( -- )
	59	;
	60
	61	headerless
	62
	63	h# 20 instance buffer: kbdname
	64	0 value kbd-hard-id
65
66	instance variable found?
67	instance variable install-usa?
68
69	: get-dropin-info ( kbd-type$ -- false \| magic$ dropin$ true )
70	2dup " sun" $= if 2drop " KBDT" " serialkbds" true exit then
71	2dup " usb" $= if 2drop " UKBD" " usbkbds" true exit then
72	2drop false
73	;
74
75	: .unsupported-kbd ( -- ) " No keyboard support found" ;
76
77	: find-kbd ( addr len -- more? )
78	drop ( addr )
79	install-usa? @ if ( addr )
80	dup >kbd-country ( addr str )
81	over >kbd-country-len c@ ( addr str,len )
82	" US-English" $= ( addr flag? )
83	else ( addr )
84	dup >kbd-type c@ keybid @ = ( addr flag? )
85	then ( addr flag? )
86	dup found? ! if ( addr )
87	dup >kbd-coding c@ ( addr coding )
88	alias-encoding = if ( addr )
89	>kbd-alias c@ keybid ! ( -- )
90	found? off ( -- )
91	restart-scan? on ( -- )
92	else ( addr )
93	dup >kbd-country ( addr str )
94	over >kbd-country-len c@ ( addr str,len )
95	>kbd-name ( addr )
96	>kbd-type ( addr' )
97	set-keytable ( -- )
98	then ( -- )
99	else ( addr )
100	drop ( -- )
101	then ( -- )
102	found? @ 0= ( flag? )
103	;
104
105	: (install-kbd) ( buffer id -- )
106	['] find-kbd is do-kbd-fn ( buffer id )
107	keybid ! ( buffer )
108	>kbd-di-data .scan-kbds ( -- )
109	;
110
111	: install-usa-maybe ( addr id -- )
112	found? @ if 2drop exit then
113
114	install-usa? on
115	swap 0 ( id addr dummy-id )
116	(install-kbd) ( id )
117	found? @ if ( id )
118	." Can't find keyboard table for keyboard layout code " .h cr
119	." Using USA keyboard table" cr
120	else
121	drop
122	then
123	;
124
125	headers
126	: install-kbd ( keyboard-type$ layout# -- false \| $error true )
127	install-usa? off ( magic$ dropin$ type )
128	found? off ( magic$ dropin$ type )
129	['] noop is base-key-table ( magic$ dropin$ type )
130	-rot find-drop-in if ( magic$ type addr len )
131	2dup >r >r drop ( magic$ type addr )
132	2swap 2 pick >kbd-di-magic 4 $= if ( type addr )
133	dup >kbd-di-default c@ ( type addr default )
134	2dup (install-kbd) ( type addr default )
135	rot ( addr default type )
136	dup nvram-table? if ( addr default type )
137	3drop ( -- )
138	else ( addr default type )
139	tuck <> if ( addr type )
140	2dup (install-kbd) ( addr type )
141	install-usa-maybe ( -- )
142	else ( addr type )
143	2drop ( -- )
144	then ( -- )
145	then ( -- )
146	else ( type' addr )
147	2drop ( -- )
148	then ( -- )
149	r> r> free-drop-in ( -- )
150	else ( type' )
151	drop ( -- )
152	then ( -- )
153	found? @ if false exit then ( -- false )
154	.unsupported-kbd true ( str,len true )
155	;
156
157	\ Currently supported list of keyboards. Contains:
158	\ French, German, Japanese, Spanish, Taiwanese, UK, US
159	\ See list supported in FWARC 2006/224
160	\ Note that list of keyboards ids below is in hex, while keyboard fcodes
161	\ are defined with decimal values, so they don't directly match.
162	\ At some point, this should probably be updated to a list of strings.
163
164	: supported-commodity-keyboards ( -- supported-kbd-list supported-kbd-len )
165	" "(08 09 0f 19 1e 20 21)"
166	;
167
168	headerless
169	\ Variables used building list of keyboard names.
170
171	0 value getbufadr \ This makes code non-reentrant. Sigh.
172	0 value getbuflen
173	0 value getbufused
174	0 value findbufadr
175	0 value findbuflen
176	0 value findbufid \ Returned id
177
178	\ Helper function for get-layout-names
179	\ Copy layout name to buffer. Called from
180	\ .scan-kbds walking through list.
181
182	: store-layout-name ( addr len -- flag )
183
184	drop dup >kbd-type c@ ( addr kbd-type )
185
186	\ Verify that this keyboard is one of the ones we're allowed to see:
187	1 swap supported-commodity-keyboards ( addr one kbd-type supported len )
188	0 do ( addr one kbd-type supported )
189	2dup i + c@ = if rot drop 0 -rot then \ if permitted, flag permission
190	loop ( addr flag kbd-type supported )
191	2drop if
192	drop true exit \ This isnt a keyboard we can use.
193	then
194
195	>kbd-country dup 1- c@ ( addr name-len )
196	dup getbufused + 1+ to getbufused ( addr name-len )
197
198	\ Only store as much string as buffer has room for
199	dup getbuflen >= if
200	drop getbuflen 1- ( addr modified-len )
201	then ( addr name-len )
202
203	\ Copy string (or partial string) into target buffer
204	>r getbufadr r@ move ( r: name-len )
205	r> dup getbufadr + dup 0 swap c! 1+ ( name-len next-buffer )
206	to getbufadr ( name-len )
207	1+ getbuflen swap - to getbuflen true ( true )
208	;
209
210
211	\ Coroutine to translate from namestring to dropin address
212	: find-layout ( addr len -- flag )
213	drop dup >kbd-country dup 1- c@ ( addr name$ )
214	findbufadr findbuflen $= ( addr flag )
215	if
216	to findbufid \ Store ID for retrieval
217	false \ End search
218	else
219	drop true \ Continue search
220	then
221	;
222
223	external
224	\ Interface to get list of keyboard layout names. Returns length of
225	\ strings it wanted to return, which might be longer than the buffer.
226	: get-layout-names ( buffer length -- length' )
227	to getbuflen to getbufadr ( )
228	0 to getbufused ( )
229	['] store-layout-name is do-kbd-fn ( )
230	" usbkbds" " find-drop-in" di-handle $call-method
231	( usbkbds len flag )
232	if
233	drop 5 + .scan-kbds ( )
234	else
235	." Cannot find usbkbds dropin" cr ( )
236	then ( )
237	getbufused ( length' )
238	;
239
240
241	\ Interface to set the keyboard layout. Returns one of three values:
242	\ 0 - success. Keyboard layout has been set
243	\ 1 - failure. No such layout name exists.
244	\ 2 - failure. Keyboard has hardware identification, cannot set layout.
245
246	: set-keyboard-layout ( $name -- flag )
247	to findbuflen to findbufadr \ Store for use by coroutine
248	kbd-hard-id if \ Check to see if open found hard-id
249	2 \ Disallow, report hard-id exists
250	else
251	0 to findbufid \ Preload no id
252
253	" usbkbds" " find-drop-in" di-handle $call-method
254	( usbkbds len flag )
255	if
256	['] find-layout is do-kbd-fn \ Set coroutine
257	drop 5 + .scan-kbds ( )
258	findbufid if
259	findbufid ( addr )
260	dup >kbd-country ( addr str )
261	over >kbd-country-len c@ ( addr str,len )
262	>kbd-name ( addr )
263	>kbd-type ( addr' )
264	set-keytable ( -- )
265	0 ( flag )
266	else
267	." Keylayout not found" cr 1 ( flag )
268	then
269	else
270	." Cannot find usbkbds dropin" cr 1 ( flag )
271	then ( flag )
272	then
273	;
274
275
276	headers