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

\ ========== 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 
\    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: @(#)tableutil.fth 1.2 99/12/01
\ purpose: 
\ copyright: Copyright 1999 Sun Microsystems, Inc.  All Rights Reserved
\

d# 8192 constant /dropin-buffer
[ifdef] debugging?
  [ifdef] complete-tables?
    h# 4000 constant /dropin-buffer
  [then]
[then]

/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

variable insert-ptr

h# 20 buffer: tablename
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 )
  cmove					( -- )
;

: 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 )

[ifdef] verbose?
  ." > Loading "				( [alias] id encoding )
  dup case 
     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 )
[then]

  \ erase the header
  kbddata-buffer 0 /kbd-table-header fill	( [alias] id encoding )

  \ Now fill it.
  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 )
  else 						( id encoding )
     kbddata-buffer				( id encoding buffer )
     dup >kbd-data insert-ptr !			( id encoding buffer )
  then						( id encoding buffer )
  tuck >kbd-coding c!				( id buffer )
  >kbd-type c!					( -- )
;

: add-kbd-table ( bytes -- )
  dup wbsplit				( bytes lo hi )
  kbddata-buffer >kbd-data-size tuck	( bytes lo addr hi addr )
  c! 1+ c!				( bytes )
  kbddata-buffer over 			( bytes addr bytes )
  dropin-insert-ptr @			( bytes addr bytes dest )
  swap cmove				( bytes )
  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!
    then
  then					( -- )
;

: list-kbd ( addr len -- true )
   over					( addr len addr )
   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 )
   else					( addr len )
     diff-encoding = if 		( addr len )
        ." delta"			( addr len )
     else				( addr len )
        ." alias"			( addr len )
     then				( addr len )
   then					( addr len )
   cr 2drop true			( -- )
;

: list-kbds ( -- )
  ['] list-kbd is do-kbd-fn		( -- )
  dropin-buffer 5 +			( addr )
  .scan-kbds
;

: find-default-kbd ( adr len -- ok? )
  over >kbd-type c@			( adr len id )
  dropin-buffer >kbd-di-default c@ <>	( adr len flag? )
  dup if				( adr len flag? )
    nip nip				( flag? )
  else					( adr len flag? )
    nip swap				( flag? adr )
    ." Default Keyboard is: "		( flag? adr )
    dup >kbd-country			( flag? adr str )
    over >kbd-country-len c@		( flag? adr str len )
    type cr				( flag? adr )
    drop				( flag? )
  then					( flag? )
;

: write-kbd-dropin ( -- )
  dropin-buffer				( adr )
  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' )
    2drop				( -- )
    ." No Default keyboard found" cr
    ." This probably means that there isn't a full table defined" cr
    abort
  else					( adr ptr' )
    ['] find-default-kbd is do-kbd-fn	( adr ptr' )
    over >kbd-di-data .scan-kbds	( adr ptr' )
  then					( adr ptr' )
[ifdef] list-kbds?			( adr ptr' )
  list-kbds				( adr ptr' )
[then]					( adr ptr' )
  1+ over -				( adr len )
  ofd @ fputs				( -- )
;

: savechar ( char -- ) kbd-char-ptr @ c! 1  kbd-char-ptr +! ;

variable num-deltas
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
[ifdef] debugging?
 fload ${BP}/pkg/keyboard/debug.fth
[then]

variable total-bytes total-bytes off
variable holding-ptr

: build-dropin-table ( -- )
  current-table 2@ $find if
    execute
  else
    ." Table Constructed improperly!" abort
  then
  0  num-deltas !
  \ FORCE a diffencoding
  diff-encoding kbddata-buffer >kbd-coding c!	( -- )
  insert-ptr @ holding-ptr !			( -- )

  0 delta-debug					( -- )
  keymap-size 0 do				( -- )
    \ save current ptr
    insert-ptr @ kbd-char-ptr !			( -- )

    \ temp place holders
    0 savechar					( -- )
    i savechar 0				( 0 )
    key-table  >k-altgmap i + c@		( 0 keycode )
    base-table >k-altgmap i + c@   over <> if	( 0 keycode )
      savechar 1 or				( flag )
    else					( keycode )
      drop  					( flag )
    then					( flag )
    key-table  >k-shiftmap i + c@		( flag keycode )
    base-table >k-shiftmap i + c@  over <> if	( flag keycode )
      savechar 2 or				( flag' )
    else					( flag keycode )
      drop 					( flag )
    then					( flag )
    key-table  >k-normalmap i + c@		( keycode )
    base-table >k-normalmap i + c@ over <> if	( keycode )
      savechar 4 or				( flag )
    else					( keycode )
      drop 					( flag )
    then					( flag )
    ?dup if					( flag )
      insert-ptr @ c!				( -- )
      1 delta-debug				( -- )
      kbd-char-ptr @ insert-ptr !		( -- )
      num-deltas dup @ 1+ swap !		( -- )
    then					( -- )
  loop						( -- )
  2 delta-debug					( -- )
  insert-ptr @ kbd-char-ptr !			( -- )
  h# ff savechar kbd-char-ptr @ insert-ptr !	( -- )
  num-deltas @					( diffs )
[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
    \ table-encoding.
[ifdef] verbose? ." , table-encoding" [then]
    table-encoding kbddata-buffer >kbd-coding c! ( -- )
    key-table holding-ptr @ /keytable move	( -- )
    table-debug					( -- )
    holding-ptr @ /keytable + insert-ptr !	( -- )
  then						( -- )
  insert-ptr @ kbddata-buffer -			( bytes )
[ifdef] verbose? ." , " dup .d ." bytes" cr [then]	( bytes )
  total-bytes @ over + total-bytes !		( bytes )
  add-kbd-table					( -- )
;

: build-alias ( -- )
  current-table 2@ $find if
    execute
  else
    ." Table Constructed improperly!" abort
  then
  insert-ptr @ kbd-char-ptr !			( -- )
  h# ff savechar kbd-char-ptr @ insert-ptr !	( -- )
  insert-ptr @ kbddata-buffer -			( bytes )
  total-bytes @ over + total-bytes !		( bytes )
  add-kbd-table					( -- )
;

: all-done ( -- )
  write-kbd-dropin				( -- )
  ofd @ fclose
  ." Keyboard data = " total-bytes @ .d ." bytes" cr
;

fload ${BP}/pkg/keyboard/tablecode.fth

: >base-table ( addr -- ) base-table /keytable move ;
[ifdef] debugging?
  [ifdef] complete-tables?
    : >base-table ( addr -- ) drop ;
  [then]
[then]

: build-empty-table ( -- ) base-table 0 /keytable fill ;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: tableutil.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: @(#)tableutil.fth 1.2 99/12/01
	43	\ purpose:
	44	\ copyright: Copyright 1999 Sun Microsystems, Inc. All Rights Reserved
	45	\
	46
	47	d# 8192 constant /dropin-buffer
	48	[ifdef] debugging?
	49	[ifdef] complete-tables?
	50	h# 4000 constant /dropin-buffer
	51	[then]
	52	[then]
	53
	54	/dropin-buffer alloc-mem constant dropin-buffer
	55	variable dropin-insert-ptr
	56
	57	false value writing-tables?
	58
	59	d# 2048 constant /kbddata-buffer
	60	/kbddata-buffer buffer: kbddata-buffer
	61	d# 1024 buffer: base-table
	62
	63	variable insert-ptr
	64
65	h# 20 buffer: tablename
66	2variable current-table tablename 0 current-table 2!
67
68	: >current-table ( adr,len -- )
69	tablename tuck ( adr buf len buf )
70	over ( adr buf len buf len )
71	current-table 2! ( adr buf len )
72	cmove ( -- )
73	;
74
75	: current-table$ ( -- adr,len ) current-table 2@ ;
76
77	: new-kbd-table ( [alias-id] id encoding -- )
78	safe-parse-word ( [alias] id encoding adr,len )
79
80	2dup >current-table ( [alias] id encoding adr,len )
81	$create ( [alias] id encoding )
82
83	[ifdef] verbose?
84	." > Loading " ( [alias] id encoding )
85	dup case
86	table-encoding of ." full " endof ( [alias] id encoding )
87	diff-encoding of ." delta " endof ( [alias] id encoding )
88	alias-encoding of ." alias " endof ( [alias] id encoding )
89	." Invalid encoding format of " drop ( [alias] id encoding )
90	endcase ( [alias] id encoding )
91
92	." table: " ( [alias] id encoding )
93	current-table$ type space ( [alias] id encoding )
94	ascii ( emit ( [alias] id encoding )
95	base @ >r hex ( [alias] id encoding )
96	over 2 .r ( [alias] id encoding )
97	r> base ! ascii ) emit space ( [alias] id encoding )
98	dup alias-encoding = if ( [alias] id encoding )
99	." alias" ( [alias] id encoding )
100	ascii ( emit ( [alias] id encoding )
101	base @ >r hex ( [alias] id encoding )
102	2 pick 2 .r ( [alias] id encoding )
103	r> base ! ascii ) emit space ( [alias] id encoding )
104	cr ( [alias] id encoding )
105	then ( [alias] id encoding )
106	[then]
107
108	\ erase the header
109	kbddata-buffer 0 /kbd-table-header fill ( [alias] id encoding )
110
111	\ Now fill it.
112	current-table$ ( [alias] id encoding adr,len )
113	dup kbddata-buffer >kbd-country-len c! ( [alias] id encoding adr len )
114	kbddata-buffer >kbd-country swap move ( [alias] id encoding )
115	dup alias-encoding = if ( alias id encoding )
116	rot ( id encoding alias )
117	kbddata-buffer tuck ( id encoding buffer alias buffer )
118	>kbd-alias c! ( id encoding buffer )
119	dup >kbd-alias-data insert-ptr ! ( id encoding buffer )
120	else ( id encoding )
121	kbddata-buffer ( id encoding buffer )
122	dup >kbd-data insert-ptr ! ( id encoding buffer )
123	then ( id encoding buffer )
124	tuck >kbd-coding c! ( id buffer )
125	>kbd-type c! ( -- )
126	;
127
128	: add-kbd-table ( bytes -- )
129	dup wbsplit ( bytes lo hi )
130	kbddata-buffer >kbd-data-size tuck ( bytes lo addr hi addr )
131	c! 1+ c! ( bytes )
132	kbddata-buffer over ( bytes addr bytes )
133	dropin-insert-ptr @ ( bytes addr bytes dest )
134	swap cmove ( bytes )
135	dropin-insert-ptr +! ( -- )
136
137	writing-tables? ( writing? )
138	kbddata-buffer >kbd-coding c@ ( writing? encoding )
139	table-encoding = and if ( -- )
140	dropin-buffer >kbd-di-default c@ h# ff if
141	\ We haven't assigned a default keybd yet
142	kbddata-buffer >kbd-type c@
143	dropin-buffer >kbd-di-default c!
144	then
145	then ( -- )
146	;
147
148	: list-kbd ( addr len -- true )
149	over ( addr len addr )
150	dup >kbd-country ( addr len addr adr )
151	swap >kbd-country-len c@ ( addr len adr,len )
152	." Name: " type ( addr len )
153	over >kbd-type c@ ." , id: " .x ( addr len )
154	over >kbd-coding c@ ( addr len encoding )
155	dup table-encoding = if ( addr len )
156	drop ." table" ( addr len )
157	else ( addr len )
158	diff-encoding = if ( addr len )
159	." delta" ( addr len )
160	else ( addr len )
161	." alias" ( addr len )
162	then ( addr len )
163	then ( addr len )
164	cr 2drop true ( -- )
165	;
166
167	: list-kbds ( -- )
168	['] list-kbd is do-kbd-fn ( -- )
169	dropin-buffer 5 + ( addr )
170	.scan-kbds
171	;
172
173	: find-default-kbd ( adr len -- ok? )
174	over >kbd-type c@ ( adr len id )
175	dropin-buffer >kbd-di-default c@ <> ( adr len flag? )
176	dup if ( adr len flag? )
177	nip nip ( flag? )
178	else ( adr len flag? )
179	nip swap ( flag? adr )
180	." Default Keyboard is: " ( flag? adr )
181	dup >kbd-country ( flag? adr str )
182	over >kbd-country-len c@ ( flag? adr str len )
183	type cr ( flag? adr )
184	drop ( flag? )
185	then ( flag? )
186	;
187
188	: write-kbd-dropin ( -- )
189	dropin-buffer ( adr )
190	dropin-insert-ptr @ ( adr ptr )
191	h# ff over c! ( adr ptr )
192	1+ h# ff over c! ( adr ptr' )
193	over >kbd-di-default c@ h# ff = if ( adr ptr' )
194	2drop ( -- )
195	." No Default keyboard found" cr
196	." This probably means that there isn't a full table defined" cr
197	abort
198	else ( adr ptr' )
199	['] find-default-kbd is do-kbd-fn ( adr ptr' )
200	over >kbd-di-data .scan-kbds ( adr ptr' )
201	then ( adr ptr' )
202	[ifdef] list-kbds? ( adr ptr' )
203	list-kbds ( adr ptr' )
204	[then] ( adr ptr' )
205	1+ over - ( adr len )
206	ofd @ fputs ( -- )
207	;
208
209	: savechar ( char -- ) kbd-char-ptr @ c! 1 kbd-char-ptr +! ;
210
211	variable num-deltas
212	defer delta-debug ' drop is delta-debug
213	defer table-debug ' noop is table-debug
214	defer build-table [ifdef] verbose? ' cr [else] ' noop [then] is build-table
215	[ifdef] debugging?
216	fload ${BP}/pkg/keyboard/debug.fth
217	[then]
218
219	variable total-bytes total-bytes off
220	variable holding-ptr
221
222	: build-dropin-table ( -- )
223	current-table 2@ $find if
224	execute
225	else
226	." Table Constructed improperly!" abort
227	then
228	0 num-deltas !
229	\ FORCE a diffencoding
230	diff-encoding kbddata-buffer >kbd-coding c! ( -- )
231	insert-ptr @ holding-ptr ! ( -- )
232
233	0 delta-debug ( -- )
234	keymap-size 0 do ( -- )
235	\ save current ptr
236	insert-ptr @ kbd-char-ptr ! ( -- )
237
238	\ temp place holders
239	0 savechar ( -- )
240	i savechar 0 ( 0 )
241	key-table >k-altgmap i + c@ ( 0 keycode )
242	base-table >k-altgmap i + c@ over <> if ( 0 keycode )
243	savechar 1 or ( flag )
244	else ( keycode )
245	drop ( flag )
246	then ( flag )
247	key-table >k-shiftmap i + c@ ( flag keycode )
248	base-table >k-shiftmap i + c@ over <> if ( flag keycode )
249	savechar 2 or ( flag' )
250	else ( flag keycode )
251	drop ( flag )
252	then ( flag )
253	key-table >k-normalmap i + c@ ( keycode )
254	base-table >k-normalmap i + c@ over <> if ( keycode )
255	savechar 4 or ( flag )
256	else ( keycode )
257	drop ( flag )
258	then ( flag )
259	?dup if ( flag )
260	insert-ptr @ c! ( -- )
261	1 delta-debug ( -- )
262	kbd-char-ptr @ insert-ptr ! ( -- )
263	num-deltas dup @ 1+ swap ! ( -- )
264	then ( -- )
265	loop ( -- )
266	2 delta-debug ( -- )
267	insert-ptr @ kbd-char-ptr ! ( -- )
268	h# ff savechar kbd-char-ptr @ insert-ptr ! ( -- )
269	num-deltas @ ( diffs )
270	[ifdef] verbose? dup if ." , " dup .d ." diffs" then [then]
271	dup 0= swap d# 96 > or if ( -- )
272	\ If we have more than 96 diffs then it is more
273	\ space efficient to change the table back to a
274	\ table-encoding.
275	[ifdef] verbose? ." , table-encoding" [then]
276	table-encoding kbddata-buffer >kbd-coding c! ( -- )
277	key-table holding-ptr @ /keytable move ( -- )
278	table-debug ( -- )
279	holding-ptr @ /keytable + insert-ptr ! ( -- )
280	then ( -- )
281	insert-ptr @ kbddata-buffer - ( bytes )
282	[ifdef] verbose? ." , " dup .d ." bytes" cr [then] ( bytes )
283	total-bytes @ over + total-bytes ! ( bytes )
284	add-kbd-table ( -- )
285	;
286
287	: build-alias ( -- )
288	current-table 2@ $find if
289	execute
290	else
291	." Table Constructed improperly!" abort
292	then
293	insert-ptr @ kbd-char-ptr ! ( -- )
294	h# ff savechar kbd-char-ptr @ insert-ptr ! ( -- )
295	insert-ptr @ kbddata-buffer - ( bytes )
296	total-bytes @ over + total-bytes ! ( bytes )
297	add-kbd-table ( -- )
298	;
299
300	: all-done ( -- )
301	write-kbd-dropin ( -- )
302	ofd @ fclose
303	." Keyboard data = " total-bytes @ .d ." bytes" cr
304	;
305
306	fload ${BP}/pkg/keyboard/tablecode.fth
307
308	: >base-table ( addr -- ) base-table /keytable move ;
309	[ifdef] debugging?
310	[ifdef] complete-tables?
311	: >base-table ( addr -- ) drop ;
312	[then]
313	[then]
314
315	: build-empty-table ( -- ) base-table 0 /keytable fill ;
316