[OpenSPARC-T2-SAM] / obp / obp / fm / kernel / stresc.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: stresc.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: @(#)stresc.fth 1.17 02/05/02
purpose:
copyright: Copyright 1991-2002 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ Copyright 1985-1990 Bradley Forthware

\ These words use the string-scanning routines to get strings out of
\ the input stream.

\ ",  --> given string, emplace the string at here and allot space
\ ,"  --> accept a "-terminated string and emplace it.
\ "   --> accept a "-terminated string and leave addr len on the stack
\ ""  --> accept a blank delimited string and leave it's address on the stac
\ [""]--> accept a blank delimited string and emplace it.
\         At run time, leave it's address on the stack

\  The improvements allow control characters and 8-bit binary numbers to
\  be embedded into string literals.  This is similar in principle to the
\  "\n" convention in C, but syntactically tuned for Forth.
\
\  The escape character is '"'.  Here is the list of escapes:
\
\     ""	"
\     "n	newline
\     "r	carret
\     "t	tab
\     "f	formfeed
\     "l	linefeed
\     "b	backspace
\     "!	bell
\     "^x	control x, where x is any printable character
\     "(HhHh)   Sequence of bytes, one byte for each pair of hex digits Hh
\               Non-hex characters will be ignored
\
\     "<whitespace> terminates the string, as usual
\
\     " followed by any other printable character not mentioned above is
\          equivalent to that character.
\
\  This new syntax is completely backwards compatible with old code, since
\  the only legal previous usage was "<whitespace>
\
\  Contrived example:
\
\  	" This is "(01,328e)"nA test xyzzy "!"! abcdefg""hijk"^bl"
\
\                   ^^^^^^  ^              ^ ^         ^     ^
\                  3 bytes  newline      2 bells       "     control b
\
\  The "(HhHhHhHh) should come in particularly handy.
\
\  Note: "n (newline) happens to be the same as "l (linefeed) under Unix,
\  but this is not true for all operating systems.


[ifndef] run-time
headerless
nuser stringbuf
nuser "select
nuser '"temp

\ Packed strings are 255 bytes + 1 NULL + 1 Paranoia.
h# 258 constant /stringbuf

\ Alloc an 4K buffer for string use
chain: init  ( -- )
   h# 1000 alloc-mem dup stringbuf !  '"temp !
   0 "select !
;

\ Each string temp buffer is 512 bytes long.
\ Note this is longer than a packed string can deal with - this is intentional
headers
: "temp  ( -- adr )
   "select dup @ tuck 1+ 7 and swap !	( n )
   d# 9 << '"temp @ + 0 over c!		( n )
;

: $save  ( adr1 len1 adr2 -- adr2 len1 )  pack count  ;

: $add ( src,len dest,len -- dest,len' )
   2 pick over + >r over >r		( src,len dest,len )
   +					( str,len dest' )
   swap cmove				( )
   r> r>				( dest,len' )
;

: $cat  ( adr len  pstr -- )  \ Append adr len to the end of pstr
   >r r@ count nip   ( addr len len' )   ( r: pstr )     
   d# 255 swap - min ( addr len' )       ( r: pstr )
   r@ count +        ( adr len end-adr ) ( r: pstr )
   swap dup >r       ( adr endadr len )  ( r: pstr len )
   cmove r> r>       ( len pstr )
   dup c@ rot + swap c!
;

headerless
: add-char  ( buffer char -- )
   over count + c!
   dup c@ ca1+
   swap c!
;

: nextchar  ( adr len -- false | adr' len' char true )
   dup  0=  if  nip exit  then	( adr len )
   over c@ >r  1 /string  r>	( adr' len' char )
   caps @  if lcc  then  true
;

: nexthex  ( adr len -- false | adr' len' digit true )
   begin
      nextchar  if         ( adr' len' char )
	 d# 16 digit  if   ( adr' len' digit )
	    true true      ( adr' len' digit true done )
	 else              ( adr' len' char )
	    drop false     ( adr' len' notdone )
	 then              ( adr' len' digit true done | adr' len' notdone )
      else                 (  )
	 false true        ( false done )
      then
   until
;
: get-hex-bytes  ( strbuf -- )
   >r				(  ) ( r: strbuf )
   ascii ) parse		( adr len ) ( r: strbuf )
   begin  nexthex  while	( adr' len' digit1 ) ( r: strbuf )
      >r  nexthex  0= ( ?? ) abort" Odd number of hex digits in string"
      r>			( adr'' len'' digit2 digit1 ) ( r: strbuf )
      4 lshift +		( adr'' len'' byte ) ( r: strbuf )
      r@ swap add-char		( adr'' len'' ) ( r: strbuf )
   repeat r> drop		(  )
;
\ : get-char  ( -- char )  input-file @ fgetc  ;
: get-char  ( -- char|-1 )
   source  >in @  /string  if  c@  1 >in +!  else  drop -1  then
;

headers
: get-string  ( -- adr len )
   "temp					( strbuf )
   begin					( strbuf )
      dup ascii " parse  rot  $cat dup		( strbuf strbuf )
      get-char  dup bl <=  if			( strbuf strbuf <bl )
         2drop count				( adr,len )
[ifexist] xref-string-hook  xref-string-hook  [then]
         exit					( adr,len )
      then					( strbuf strbuf char )
      case
         ascii n of  newline            add-char  endof
         ascii r of  carret             add-char  endof
         ascii t of  control I          add-char  endof
         ascii f of  control L          add-char  endof
         ascii l of  linefeed           add-char  endof
         ascii b of  control H          add-char  endof
         ascii ! of  bell               add-char  endof
         ascii ^ of  get-char h# 1f and add-char  endof
         ascii ( of  get-hex-bytes                endof
         ( default ) add-char false
      endcase					( strbuf )
   again					( strbuf )
;

: .(  \ string)  (s -- )
   ascii ) parse
[ifexist] xref-string-hook  xref-string-hook  [then]
   type
; immediate

\ : (   \ string  (s -- )  \ Skips to next )
\    ascii ) parse 2drop
\ ; immediate
[then]

: ",    (s adr len -- )
   dup 2+ taligned  here swap  note-string  allot  place
;

[ifndef] run-time
: ,"  \ string"  (s -- )
   get-string  ",
;

: ."  \ string"  (s -- )
   +level compile (.")   ," -level
; immediate

: s"  \ string   (s -- adr len )
   ascii " parse
   state @  if  compile (") ",  else  "temp $save  then
; immediate

: "   \ string"  (s -- adr len )
   get-string
   state @  if  compile (") ",  else  "temp $save  then
; immediate

: [""]  \ word  (s Compile-time: -- )
        (s Run-time: -- pstr )
   compile ("s)  safe-parse-word ",
; immediate

\ Obsolete
: ["]   \ string"  (s -- str )
   compile ("s)    ,"
; immediate

: \  \ rest-of-line  (s -- )      \ skips rest of line
   -1 parse
[ifexist] xref-string-hook  xref-string-hook  [then]
    2drop
; immediate

: compile-string  ( adr len -- )
   state @  if
      compile ("s) ",
   else
      "temp pack 
   then
;
: ""   \ name  ( -- pstr )
   safe-parse-word  compile-string
; immediate

: p"   \ string"  ( -- pstr )
   get-string  compile-string
; immediate

: c"   \ string"  ( -- pstr )
   ascii " parse
   compile-string
; immediate
[then]

create nullstring 0 c, 0 c,

\ Words for copying strings
\ Places a series of bytes in memory at to as a packed string
: place     (s adr len to-adr -- )  pack drop  ;

: place-cstr  ( adr len cstr-adr -- cstr-adr )
   >r  tuck r@ swap cmove  ( len ) r@ +  0 swap c!  r>
;

: even      (s n -- n | n+1 )  dup 1 and +  ;

\ Nullfix
: +str  (s pstr -- adr )     count + 1+ taligned ;

\ Copy a packed string from "from-pstr" to "to-pstr"
: "copy (s from-pstr to-pstr -- )      >r count r> place ;

\ Copy a packed string from "from-pstr" to "to-pstr", returning "to-pstr"
: "move (s from-pstr to-pstr -- to-pstr )   >r count r> pack  ;

\ : count      (s adr -- adr+1 len )  dup 1+   swap c@   ;
: /string  ( adr len cnt -- adr' len' )  tuck - -rot + swap  ;

: printable?  ( n -- flag ) \ true if n is a printable ascii character
   dup bl th 7f within  swap  th 80  th ff  between  or
;
: white-space? ( n -- flag ) \ true is n is non-printable? or a blank
   dup printable? 0=  swap  bl =  or
;

: -leading  ( adr len -- adr' len' )
   begin  dup  while   ( adr' len' )
      over c@  white-space? 0=  if  exit  then
      swap 1+ swap 1-
   repeat
;

: -trailing  (s adr len -- adr len' )
   dup  0  ?do   2dup + 1- c@   white-space? 0=  ?leave  1-    loop
;

: upper  (s adr len -- )  bounds  ?do i dup c@ upc swap c!  loop  ;
: lower  (s adr len -- )  bounds  ?do i dup c@ lcc swap c!  loop  ;

nuser caps
: f83-compare  (s adr adr2 len -- -1 | 0 | 1 )
   caps @  if  caps-comp  else  comp  then
;
headers
\ Unpacked string comparison
: +-1  ( n -- -1|0|+1 )  0< 2* 1+  ;
: compare  (s adr1 len1 adr2 len2 -- same? )
   rot 2dup 2>r min             ( adr1 adr2 min-len )  ( r: len2 len1 )
   comp dup  if                 ( +-1 )
      2r> 2drop                 ( +-1 )  \ Initial substrings differ
   else                         ( 0 )
      drop  2r> -               ( diff ) \ Initial substrings are the same
      \ This is tricky.  We want to convert zero to zero, positive
      \ numbers to -1, and negative numbers to +1.  Here's how it works:
      \ "dup  if  ..  then" leave 0 unchanged, and nonzero number are
      \ transformed as follows:
      \       +n  -n
      \ 0>    -1   0
      \ 2*    -2   0
      \ 1+    -1   1
      dup  if  0> 2* 1+  then
   then
;
\ $= can be defined as "compare 0=", but $= is used much more often,
\ and doesn't require all the tricky argument fixups, so it makes
\ sense to define $= directly, so it runs quite a bit faster.
: $=  (s adr1 len1 adr2 len2 -- same? )
   rot tuck  <>  if  3drop false exit  then   ( adr1 adr2 len1 )
   comp 0=
;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: stresc.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: @(#)stresc.fth 1.17 02/05/02
	43	purpose:
	44	copyright: Copyright 1991-2002 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	\ Copyright 1985-1990 Bradley Forthware
	48
	49	\ These words use the string-scanning routines to get strings out of
	50	\ the input stream.
	51
	52	\ ", --> given string, emplace the string at here and allot space
	53	\ ," --> accept a "-terminated string and emplace it.
	54	\ " --> accept a "-terminated string and leave addr len on the stack
	55	\ "" --> accept a blank delimited string and leave it's address on the stac
	56	\ [""]--> accept a blank delimited string and emplace it.
	57	\ At run time, leave it's address on the stack
	58
	59	\ The improvements allow control characters and 8-bit binary numbers to
	60	\ be embedded into string literals. This is similar in principle to the
	61	\ "\n" convention in C, but syntactically tuned for Forth.
	62	\
	63	\ The escape character is '"'. Here is the list of escapes:
	64	\
65	\ "" "
66	\ "n newline
67	\ "r carret
68	\ "t tab
69	\ "f formfeed
70	\ "l linefeed
71	\ "b backspace
72	\ "! bell
73	\ "^x control x, where x is any printable character
74	\ "(HhHh) Sequence of bytes, one byte for each pair of hex digits Hh
75	\ Non-hex characters will be ignored
76	\
77	\ "<whitespace> terminates the string, as usual
78	\
79	\ " followed by any other printable character not mentioned above is
80	\ equivalent to that character.
81	\
82	\ This new syntax is completely backwards compatible with old code, since
83	\ the only legal previous usage was "<whitespace>
84	\
85	\ Contrived example:
86	\
87	\ " This is "(01,328e)"nA test xyzzy "!"! abcdefg""hijk"^bl"
88	\
89	\ ^^^^^^ ^ ^ ^ ^ ^
90	\ 3 bytes newline 2 bells " control b
91	\
92	\ The "(HhHhHhHh) should come in particularly handy.
93	\
94	\ Note: "n (newline) happens to be the same as "l (linefeed) under Unix,
95	\ but this is not true for all operating systems.
96
97
98	[ifndef] run-time
99	headerless
100	nuser stringbuf
101	nuser "select
102	nuser '"temp
103
104	\ Packed strings are 255 bytes + 1 NULL + 1 Paranoia.
105	h# 258 constant /stringbuf
106
107	\ Alloc an 4K buffer for string use
108	chain: init ( -- )
109	h# 1000 alloc-mem dup stringbuf ! '"temp !
110	0 "select !
111	;
112
113	\ Each string temp buffer is 512 bytes long.
114	\ Note this is longer than a packed string can deal with - this is intentional
115	headers
116	: "temp ( -- adr )
117	"select dup @ tuck 1+ 7 and swap ! ( n )
118	d# 9 << '"temp @ + 0 over c! ( n )
119	;
120
121	: $save ( adr1 len1 adr2 -- adr2 len1 ) pack count ;
122
123	: $add ( src,len dest,len -- dest,len' )
124	2 pick over + >r over >r ( src,len dest,len )
125	+ ( str,len dest' )
126	swap cmove ( )
127	r> r> ( dest,len' )
128	;
129
130	: $cat ( adr len pstr -- ) \ Append adr len to the end of pstr
131	>r r@ count nip ( addr len len' ) ( r: pstr )
132	d# 255 swap - min ( addr len' ) ( r: pstr )
133	r@ count + ( adr len end-adr ) ( r: pstr )
134	swap dup >r ( adr endadr len ) ( r: pstr len )
135	cmove r> r> ( len pstr )
136	dup c@ rot + swap c!
137	;
138
139	headerless
140	: add-char ( buffer char -- )
141	over count + c!
142	dup c@ ca1+
143	swap c!
144	;
145
146	: nextchar ( adr len -- false \| adr' len' char true )
147	dup 0= if nip exit then ( adr len )
148	over c@ >r 1 /string r> ( adr' len' char )
149	caps @ if lcc then true
150	;
151
152	: nexthex ( adr len -- false \| adr' len' digit true )
153	begin
154	nextchar if ( adr' len' char )
155	d# 16 digit if ( adr' len' digit )
156	true true ( adr' len' digit true done )
157	else ( adr' len' char )
158	drop false ( adr' len' notdone )
159	then ( adr' len' digit true done \| adr' len' notdone )
160	else ( )
161	false true ( false done )
162	then
163	until
164	;
165	: get-hex-bytes ( strbuf -- )
166	>r ( ) ( r: strbuf )
167	ascii ) parse ( adr len ) ( r: strbuf )
168	begin nexthex while ( adr' len' digit1 ) ( r: strbuf )
169	>r nexthex 0= ( ?? ) abort" Odd number of hex digits in string"
170	r> ( adr'' len'' digit2 digit1 ) ( r: strbuf )
171	4 lshift + ( adr'' len'' byte ) ( r: strbuf )
172	r@ swap add-char ( adr'' len'' ) ( r: strbuf )
173	repeat r> drop ( )
174	;
175	\ : get-char ( -- char ) input-file @ fgetc ;
176	: get-char ( -- char\|-1 )
177	source >in @ /string if c@ 1 >in +! else drop -1 then
178	;
179
180	headers
181	: get-string ( -- adr len )
182	"temp ( strbuf )
183	begin ( strbuf )
184	dup ascii " parse rot $cat dup ( strbuf strbuf )
185	get-char dup bl <= if ( strbuf strbuf <bl )
186	2drop count ( adr,len )
187	[ifexist] xref-string-hook xref-string-hook [then]
188	exit ( adr,len )
189	then ( strbuf strbuf char )
190	case
191	ascii n of newline add-char endof
192	ascii r of carret add-char endof
193	ascii t of control I add-char endof
194	ascii f of control L add-char endof
195	ascii l of linefeed add-char endof
196	ascii b of control H add-char endof
197	ascii ! of bell add-char endof
198	ascii ^ of get-char h# 1f and add-char endof
199	ascii ( of get-hex-bytes endof
200	( default ) add-char false
201	endcase ( strbuf )
202	again ( strbuf )
203	;
204
205	: .( \ string) (s -- )
206	ascii ) parse
207	[ifexist] xref-string-hook xref-string-hook [then]
208	type
209	; immediate
210
211	\ : ( \ string (s -- ) \ Skips to next )
212	\ ascii ) parse 2drop
213	\ ; immediate
214	[then]
215
216	: ", (s adr len -- )
217	dup 2+ taligned here swap note-string allot place
218	;
219
220	[ifndef] run-time
221	: ," \ string" (s -- )
222	get-string ",
223	;
224
225	: ." \ string" (s -- )
226	+level compile (.") ," -level
227	; immediate
228
229	: s" \ string (s -- adr len )
230	ascii " parse
231	state @ if compile (") ", else "temp $save then
232	; immediate
233
234	: " \ string" (s -- adr len )
235	get-string
236	state @ if compile (") ", else "temp $save then
237	; immediate
238
239	: [""] \ word (s Compile-time: -- )
240	(s Run-time: -- pstr )
241	compile ("s) safe-parse-word ",
242	; immediate
243
244	\ Obsolete
245	: ["] \ string" (s -- str )
246	compile ("s) ,"
247	; immediate
248
249	: \ \ rest-of-line (s -- ) \ skips rest of line
250	-1 parse
251	[ifexist] xref-string-hook xref-string-hook [then]
252	2drop
253	; immediate
254
255	: compile-string ( adr len -- )
256	state @ if
257	compile ("s) ",
258	else
259	"temp pack
260	then
261	;
262	: "" \ name ( -- pstr )
263	safe-parse-word compile-string
264	; immediate
265
266	: p" \ string" ( -- pstr )
267	get-string compile-string
268	; immediate
269
270	: c" \ string" ( -- pstr )
271	ascii " parse
272	compile-string
273	; immediate
274	[then]
275
276	create nullstring 0 c, 0 c,
277
278	\ Words for copying strings
279	\ Places a series of bytes in memory at to as a packed string
280	: place (s adr len to-adr -- ) pack drop ;
281
282	: place-cstr ( adr len cstr-adr -- cstr-adr )
283	>r tuck r@ swap cmove ( len ) r@ + 0 swap c! r>
284	;
285
286	: even (s n -- n \| n+1 ) dup 1 and + ;
287
288	\ Nullfix
289	: +str (s pstr -- adr ) count + 1+ taligned ;
290
291	\ Copy a packed string from "from-pstr" to "to-pstr"
292	: "copy (s from-pstr to-pstr -- ) >r count r> place ;
293
294	\ Copy a packed string from "from-pstr" to "to-pstr", returning "to-pstr"
295	: "move (s from-pstr to-pstr -- to-pstr ) >r count r> pack ;
296
297	\ : count (s adr -- adr+1 len ) dup 1+ swap c@ ;
298	: /string ( adr len cnt -- adr' len' ) tuck - -rot + swap ;
299
300	: printable? ( n -- flag ) \ true if n is a printable ascii character
301	dup bl th 7f within swap th 80 th ff between or
302	;
303	: white-space? ( n -- flag ) \ true is n is non-printable? or a blank
304	dup printable? 0= swap bl = or
305	;
306
307	: -leading ( adr len -- adr' len' )
308	begin dup while ( adr' len' )
309	over c@ white-space? 0= if exit then
310	swap 1+ swap 1-
311	repeat
312	;
313
314	: -trailing (s adr len -- adr len' )
315	dup 0 ?do 2dup + 1- c@ white-space? 0= ?leave 1- loop
316	;
317
318	: upper (s adr len -- ) bounds ?do i dup c@ upc swap c! loop ;
319	: lower (s adr len -- ) bounds ?do i dup c@ lcc swap c! loop ;
320
321	nuser caps
322	: f83-compare (s adr adr2 len -- -1 \| 0 \| 1 )
323	caps @ if caps-comp else comp then
324	;
325	headers
326	\ Unpacked string comparison
327	: +-1 ( n -- -1\|0\|+1 ) 0< 2* 1+ ;
328	: compare (s adr1 len1 adr2 len2 -- same? )
329	rot 2dup 2>r min ( adr1 adr2 min-len ) ( r: len2 len1 )
330	comp dup if ( +-1 )
331	2r> 2drop ( +-1 ) \ Initial substrings differ
332	else ( 0 )
333	drop 2r> - ( diff ) \ Initial substrings are the same
334	\ This is tricky. We want to convert zero to zero, positive
335	\ numbers to -1, and negative numbers to +1. Here's how it works:
336	\ "dup if .. then" leave 0 unchanged, and nonzero number are
337	\ transformed as follows:
338	\ +n -n
339	\ 0> -1 0
340	\ 2* -2 0
341	\ 1+ -1 1
342	dup if 0> 2* 1+ then
343	then
344	;
345	\ $= can be defined as "compare 0=", but $= is used much more often,
346	\ and doesn't require all the tricky argument fixups, so it makes
347	\ sense to define $= directly, so it runs quite a bit faster.
348	: $= (s adr1 len1 adr2 len2 -- same? )
349	rot tuck <> if 3drop false exit then ( adr1 adr2 len1 )
350	comp 0=
351	;