[OpenSPARC-T2-SAM] / obp / obp / fm / lib / cmdcpl.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: cmdcpl.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 ============================================
\ cmdcpl.fth 2.7 96/02/29
\ Copyright 1985-1990 Bradley Forthware

\ Command completion package a la TENEX.

decimal
only forth also definitions
vocabulary command-completion
only forth also hidden also command-completion definitions

headerless

\ Interfaces to the line editing routines
defer find-end ( -- )        \ Move the cursor to the end of the word
defer cinsert  ( char -- )   \ Insert a character into the line
defer cerase   ( -- )        \ Delete the character before the cursor

\ Some variables are hijacked from the line editing code and used here:
\ line-start-adr #before

\ Index of char at the beginning of the latest word in the input buffer
variable start-of-word

20 constant #candidates-max
variable #candidates   0 #candidates !
#candidates-max /n*  buffer: candidates
variable overflow

: word-to-string  ( -- str )
   line-start-adr  start-of-word @  +  ( addr of start of word )
   #before         start-of-word @  -  ( start-addr len )
   'word  place
   'word
;

: collect-string  ( -- str )
   \ Finds start of this word and the current length of the word and
   \ leaves the address of a packed string which contains that word
   find-end
   #before    start-of-word !
   #before  if
       line-start-adr  #before  1-  bounds  ( bufend bufstart )
       swap  ( bufstart bufend )  do    \ Loop runs backwards over buffer
          i c@  bl =  if  leave  then
          -1 start-of-word +!
       -1 +loop
   then
   word-to-string  ( str )
;

: substring?  ( pstr anf -- f )

   name>string  rot count 2swap  ( pstr-adr,len name-adr,len )

   \ It's not a substring if the string is longer than the name
   2 pick  <  if  2drop drop false exit  then  ( pstr-adr pstr-len name-adr )

   true swap 2swap   ( true name-adr pstr-adr pstr-len )
   bounds  ?do       ( flag name-adr )
      dup c@  i c@ <>  if  swap 0= swap  leave   then  ( flag name-adr )
      1+             ( flag name-adr' )
   loop              ( flag name-adr'' )
   drop
;

: new-candidate  ( anf -- )
   #candidates @  #candidates-max >=  if  drop overflow on  exit  then
   candidates #candidates @ na+   !   (  )
   1 #candidates +!
;

: find-candidates-in-voc  ( str voc -- str )
   swap >r  0 swap              ( alf voc-acf ) ( r: str )
   begin  another-word?  while  ( str alf voc-acf  anf ) ( r: str )
      r@ over substring?  if  new-candidate  else  drop  then
   repeat  r>  ( str )
;

: find-candidates  ( str -- )
   #candidates off  overflow off
   prior off        ( str )
   dup c@ 0=  if  drop  exit  then     \ Don't bother with null search strings
   \ Maybe it would be better to search all the vocabularies in the system?
   context  #vocs /link *  bounds  do
      i another-link?  if                ( str voc )
         dup prior @ over prior !  = if  ( str voc )
            drop                         ( str )
         else
	    find-candidates-in-voc       ( str )
         then
      then                               ( str )
   /link +loop
   drop
;
\ True if "char" is different from the "char#"-th character in name
: cclash?  ( char# char anf -- char# char flag )
   name>string        ( char# char str-adr count )
   3 pick <=  if      ( char# char str-adr )
      drop true       \ str too short is a clash
   else               ( char# char str-adr )
      2 pick +  c@ over <>
   then
;

\ If all the candidate words have the same character in the "char#"-th
\ position, leave that character and true, otherwise just leave false.
: candidates-agree?  ( char# -- char true | false )

\ if the test string is the same length as the first candidate,
\ then the first candidate has no char at position char#, so there
\ can be no agreement.  Since the test string is a substring of all
\ candidates, the > condition should not happen

   candidates @  name>string               ( char# name-adr name-len )
   2 pick =  if  2drop false  exit  then   ( char# name-adr )
   over + c@                               ( char# char )

   \ now test all other candidates to see if their "char#"-th character
   \ is the same as that of the first candidate

   true -rot                               ( true char# char )

   candidates na1+  #candidates @  1-  /n*  bounds  ?do   ( flag char# char )
       i @ cclash?  if                                    ( flag char# char )
          rot drop  false -rot  leave
       then
   /n +loop                                               ( flag char# char )
   rot if   nip true   else   2drop false   then
;
: expand-initial-substring  ( -- )
   #before  start-of-word @  -
   begin                         ( current-length )
         dup candidates-agree?   ( current-len [ char true ] | false )
   while
         cinsert  1+             ( current-length )
   repeat
   drop
;

h# 34 buffer: candidate

\ True if there is only one candidate or if all the names are the same.
: one-candidate?  ( -- flag )

   \ We can't just compare the pointers, because we are checking for
   \ different words with the same name.

   candidates @ name>string  candidate place
   true
   candidates  #candidates @ /n*  bounds  ?do  ( flag )
      i @  name>string  candidate count        ( flag )
      $=  0=  if  0= leave  then               ( flag )
   /n +loop                                    ( flag )
;

: do-erase  ( -- ) \ Side effect: span and bufcursor may be reduced
   begin
      word-to-string   ( addr )
      dup c@ 0=  if  drop exit  then	\ Stop if the entire word is gone
      find-candidates
      #candidates @ 0=
   while
      cerase
   repeat
;

: do-expand  ( -- )
   expand-initial-substring

   \ Beep if the expansion does not result in a unique choice
   one-candidate?  if  bl cinsert  else beep  then
;

: expand-word  ( -- )
   collect-string find-candidates  ( )
   #candidates @  if   do-expand   else  do-erase  then
;

: show-candidates  ( -- )
   d# 64 rmargin !
   candidates #candidates  @  /n* bounds  ?do  ?cr  i @ .id  /n +loop
   overflow @  if  ." ..."  then
;

: do-show  ( -- )
   cr
   collect-string  dup c@  if       ( str )
      find-candidates show-candidates
   else
      drop ." Any word at all is a candidate." cr
           ." Use words to see the entire dictionary"
   then
   retype-line
;
headers

only forth also definitions
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: cmdcpl.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	\ cmdcpl.fth 2.7 96/02/29
	43	\ Copyright 1985-1990 Bradley Forthware
	44
	45	\ Command completion package a la TENEX.
	46
	47	decimal
	48	only forth also definitions
	49	vocabulary command-completion
	50	only forth also hidden also command-completion definitions
	51
	52	headerless
	53
	54	\ Interfaces to the line editing routines
	55	defer find-end ( -- ) \ Move the cursor to the end of the word
	56	defer cinsert ( char -- ) \ Insert a character into the line
	57	defer cerase ( -- ) \ Delete the character before the cursor
	58
	59	\ Some variables are hijacked from the line editing code and used here:
	60	\ line-start-adr #before
	61
	62	\ Index of char at the beginning of the latest word in the input buffer
	63	variable start-of-word
	64
65	20 constant #candidates-max
66	variable #candidates 0 #candidates !
67	#candidates-max /n* buffer: candidates
68	variable overflow
69
70	: word-to-string ( -- str )
71	line-start-adr start-of-word @ + ( addr of start of word )
72	#before start-of-word @ - ( start-addr len )
73	'word place
74	'word
75	;
76
77	: collect-string ( -- str )
78	\ Finds start of this word and the current length of the word and
79	\ leaves the address of a packed string which contains that word
80	find-end
81	#before start-of-word !
82	#before if
83	line-start-adr #before 1- bounds ( bufend bufstart )
84	swap ( bufstart bufend ) do \ Loop runs backwards over buffer
85	i c@ bl = if leave then
86	-1 start-of-word +!
87	-1 +loop
88	then
89	word-to-string ( str )
90	;
91
92	: substring? ( pstr anf -- f )
93
94	name>string rot count 2swap ( pstr-adr,len name-adr,len )
95
96	\ It's not a substring if the string is longer than the name
97	2 pick < if 2drop drop false exit then ( pstr-adr pstr-len name-adr )
98
99	true swap 2swap ( true name-adr pstr-adr pstr-len )
100	bounds ?do ( flag name-adr )
101	dup c@ i c@ <> if swap 0= swap leave then ( flag name-adr )
102	1+ ( flag name-adr' )
103	loop ( flag name-adr'' )
104	drop
105	;
106
107	: new-candidate ( anf -- )
108	#candidates @ #candidates-max >= if drop overflow on exit then
109	candidates #candidates @ na+ ! ( )
110	1 #candidates +!
111	;
112
113	: find-candidates-in-voc ( str voc -- str )
114	swap >r 0 swap ( alf voc-acf ) ( r: str )
115	begin another-word? while ( str alf voc-acf anf ) ( r: str )
116	r@ over substring? if new-candidate else drop then
117	repeat r> ( str )
118	;
119
120	: find-candidates ( str -- )
121	#candidates off overflow off
122	prior off ( str )
123	dup c@ 0= if drop exit then \ Don't bother with null search strings
124	\ Maybe it would be better to search all the vocabularies in the system?
125	context #vocs /link * bounds do
126	i another-link? if ( str voc )
127	dup prior @ over prior ! = if ( str voc )
128	drop ( str )
129	else
130	find-candidates-in-voc ( str )
131	then
132	then ( str )
133	/link +loop
134	drop
135	;
136	\ True if "char" is different from the "char#"-th character in name
137	: cclash? ( char# char anf -- char# char flag )
138	name>string ( char# char str-adr count )
139	3 pick <= if ( char# char str-adr )
140	drop true \ str too short is a clash
141	else ( char# char str-adr )
142	2 pick + c@ over <>
143	then
144	;
145
146	\ If all the candidate words have the same character in the "char#"-th
147	\ position, leave that character and true, otherwise just leave false.
148	: candidates-agree? ( char# -- char true \| false )
149
150	\ if the test string is the same length as the first candidate,
151	\ then the first candidate has no char at position char#, so there
152	\ can be no agreement. Since the test string is a substring of all
153	\ candidates, the > condition should not happen
154
155	candidates @ name>string ( char# name-adr name-len )
156	2 pick = if 2drop false exit then ( char# name-adr )
157	over + c@ ( char# char )
158
159	\ now test all other candidates to see if their "char#"-th character
160	\ is the same as that of the first candidate
161
162	true -rot ( true char# char )
163
164	candidates na1+ #candidates @ 1- /n* bounds ?do ( flag char# char )
165	i @ cclash? if ( flag char# char )
166	rot drop false -rot leave
167	then
168	/n +loop ( flag char# char )
169	rot if nip true else 2drop false then
170	;
171	: expand-initial-substring ( -- )
172	#before start-of-word @ -
173	begin ( current-length )
174	dup candidates-agree? ( current-len [ char true ] \| false )
175	while
176	cinsert 1+ ( current-length )
177	repeat
178	drop
179	;
180
181	h# 34 buffer: candidate
182
183	\ True if there is only one candidate or if all the names are the same.
184	: one-candidate? ( -- flag )
185
186	\ We can't just compare the pointers, because we are checking for
187	\ different words with the same name.
188
189	candidates @ name>string candidate place
190	true
191	candidates #candidates @ /n* bounds ?do ( flag )
192	i @ name>string candidate count ( flag )
193	$= 0= if 0= leave then ( flag )
194	/n +loop ( flag )
195	;
196
197	: do-erase ( -- ) \ Side effect: span and bufcursor may be reduced
198	begin
199	word-to-string ( addr )
200	dup c@ 0= if drop exit then \ Stop if the entire word is gone
201	find-candidates
202	#candidates @ 0=
203	while
204	cerase
205	repeat
206	;
207
208	: do-expand ( -- )
209	expand-initial-substring
210
211	\ Beep if the expansion does not result in a unique choice
212	one-candidate? if bl cinsert else beep then
213	;
214
215	: expand-word ( -- )
216	collect-string find-candidates ( )
217	#candidates @ if do-expand else do-erase then
218	;
219
220	: show-candidates ( -- )
221	d# 64 rmargin !
222	candidates #candidates @ /n* bounds ?do ?cr i @ .id /n +loop
223	overflow @ if ." ..." then
224	;
225
226	: do-show ( -- )
227	cr
228	collect-string dup c@ if ( str )
229	find-candidates show-candidates
230	else
231	drop ." Any word at all is a candidate." cr
232	." Use words to see the entire dictionary"
233	then
234	retype-line
235	;
236	headers
237
238	only forth also definitions