[OpenSPARC-T2-SAM] / obp / obp / pkg / netinet / strings.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: strings.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: @(#)strings.fth 1.1 04/09/07
purpose: String utility functions
copyright: Copyright 2004 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

headerless

: null$ ( -- adr 0 ) " " ;

: byte-compare ( adr1 len1 adr2 len2 -- same? )
   rot tuck =  if  comp 0=  else  3drop false  then
;

\ Skip over 'n' characters in a string.
: /string ( adr len n -- adr' len' )  tuck - >r + r> ;

\ String compare.
: $=  ( adr1 len1 adr2 len2 -- same? )
   byte-compare
;

\ Case-insensitive string compare.
: $case= ( adr1 len1 adr2 len2 -- same? )
   rot tuck <>  if  3drop false exit  then		( adr1 adr2 len1 )
   0  ?do 
      over i ca+ c@ lcc  over i ca+ c@ lcc  <>  if
         2drop false unloop exit
      then
   loop
   2drop true
;

\ Decimal string to number conversion.
: $dnumber ( adr,len -- n false | true )
   base @ >r  decimal  $number  r> base !
;

\ Hexadecimal string to number conversion.
: $hnumber ( adr,len -- n false | true )
   base @ >r  hex  $number  r> base !
;

\ Return a pointer to the first occurence of a character in a string.
: strchr ( adr len char -- adr' )
   >r  over ca+  swap
   begin  2dup >  while
      dup c@  r@ =  if  nip r> drop exit  then  ca1+
   repeat
   r> 3drop 0
;

\ Locate the first occurence of a substring in a string. Returns a
\ pointer to the located substring, or 0 if the substring is not 
\ found. If the substring is of zero length, a pointer to the 
\ string will be returned.
: strstr ( str$ substr$ -- adr | 0 )
   2 pick over <  if				( adr len substr$ ) 
      2drop 2drop 0 exit			( 0 )
   then						( adr len substr$ )
   rot over - 1+  0  ?do			( adr substr$ ) 
      3dup comp 0=  if				( adr substr$ ) 
         2drop unloop exit			( adr )
      then					( adr substr$ )
      rot  ca1+  -rot				( adr' substr$ )
   loop						( adr' substr$ )
   3drop 0					( 0 )
;

\ Skip over all occurences of specified characters at the beginning
\ of the string.
: string-skipchars ( str$ chars$ -- str$' )
   2over bounds ?do					( str$ chars$ )
      2dup i c@ strchr if				( str$ chars$ )
         2swap  1 /string  2swap			( str$' chars$ )
      else						( str$ chars$ )
         leave						( str$ chars$ )
      then						( str$ chars$ )
   loop							( str$' chars$ )
   2drop						( str$' )
;

\ Get the next token from the text string. Tokens are delimited by one 
\ or more characters specified in the delimiter string.
: strtok ( text$ delim$ -- rem$ tok$ )
   2swap 2over  string-skipchars  2swap			( text$' delim$ )
   2over bounds ?do					( text$' delim$ )
      2dup  i c@ strchr if				( text$' delim$ )
         2drop  i c@ left-parse-string unloop exit	( rem$ tok$ )
      then						( text$' delim$ )
   loop							( text$' delim$ )
   2drop null$ 2swap					( null$ tok$ )
;

\ Split a string into 2 substrings.
: string-split ( adr len n -- adr+n len-n adr n )
   >r  2dup r@ /string  2swap drop r>
;

\ Get contents of a quoted string.
: qdstring>string ( $ -- $' )
   over c@ ascii " =  if  
      1 /string  ascii " left-parse-string  2swap 2drop
   then
;

\ Concatenate strings.
: strcat ( adr1 len1 adr2 len2 -- adr1 len1+len2 )
   2over 2over 2swap ca+ swap move  nip +
;

\ Store string as a null-terminated string and return pointer past the
\ terminating null character.
: $cstrput ( str len dest-adr -- end-adr )
   swap  2dup ca+ >r  move  0 r@ c!  r> ca1+
;

: cstrlen ( cstr -- length )
   dup  begin  dup c@  while  ca1+  repeat  swap -
;

: cscount ( cstr -- adr len )  dup cstrlen ;

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

d# 64  instance buffer:  hexascii-buf

\ Get ASCII hexadecimal representation of octet stream 
: octet-to-hexascii ( data datalen -- buf buflen )
   hexascii-buf 0  2swap				( buf 0 data datalen )
   dup 0=  over d# 32 >  or  if				( buf 0 data datalen )
      2drop exit					( buf 0 )
   then							( buf 0 data datalen )
   base @ >r  hex					( buf 0 data datalen )
   bounds ?do						( buf len )
      i c@  <# u# u# u#>				( buf len $ )
      2over ca+  swap move				( buf len )
      2+						( buf len' )
   loop							( buf len' )
   2dup upper						( buf len' )
   r> base !						( buf buflen )
;

\ Get octet stream representation of ASCII hexadecimal string
: hexascii-to-octet ( data datalen -- buf buflen )
   hexascii-buf 0  2swap				( buf 0 data datalen )
   dup 0=  over d# 128 > or  over  2 mod 0<>  or if	( buf 0 data datalen )
      2drop exit					( buf 0 )
   then							( buf 0 data datalen )
   bounds ?do						( buf len )
      i 2 $hnumber  if					( buf len )
         drop 0 unloop exit				( buf 0 )
      then						( buf len n )
      >r  2dup ca+  r> swap c!				( buf len )
      1+						( buf len' )
   2 +loop						( buf len' )
;

headers
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: strings.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: @(#)strings.fth 1.1 04/09/07
	43	purpose: String utility functions
	44	copyright: Copyright 2004 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	headerless
	48
	49	: null$ ( -- adr 0 ) " " ;
	50
	51	: byte-compare ( adr1 len1 adr2 len2 -- same? )
	52	rot tuck = if comp 0= else 3drop false then
	53	;
	54
	55	\ Skip over 'n' characters in a string.
	56	: /string ( adr len n -- adr' len' ) tuck - >r + r> ;
	57
	58	\ String compare.
	59	: $= ( adr1 len1 adr2 len2 -- same? )
	60	byte-compare
	61	;
	62
	63	\ Case-insensitive string compare.
	64	: $case= ( adr1 len1 adr2 len2 -- same? )
65	rot tuck <> if 3drop false exit then ( adr1 adr2 len1 )
66	0 ?do
67	over i ca+ c@ lcc over i ca+ c@ lcc <> if
68	2drop false unloop exit
69	then
70	loop
71	2drop true
72	;
73
74	\ Decimal string to number conversion.
75	: $dnumber ( adr,len -- n false \| true )
76	base @ >r decimal $number r> base !
77	;
78
79	\ Hexadecimal string to number conversion.
80	: $hnumber ( adr,len -- n false \| true )
81	base @ >r hex $number r> base !
82	;
83
84	\ Return a pointer to the first occurence of a character in a string.
85	: strchr ( adr len char -- adr' )
86	>r over ca+ swap
87	begin 2dup > while
88	dup c@ r@ = if nip r> drop exit then ca1+
89	repeat
90	r> 3drop 0
91	;
92
93	\ Locate the first occurence of a substring in a string. Returns a
94	\ pointer to the located substring, or 0 if the substring is not
95	\ found. If the substring is of zero length, a pointer to the
96	\ string will be returned.
97	: strstr ( str$ substr$ -- adr \| 0 )
98	2 pick over < if ( adr len substr$ )
99	2drop 2drop 0 exit ( 0 )
100	then ( adr len substr$ )
101	rot over - 1+ 0 ?do ( adr substr$ )
102	3dup comp 0= if ( adr substr$ )
103	2drop unloop exit ( adr )
104	then ( adr substr$ )
105	rot ca1+ -rot ( adr' substr$ )
106	loop ( adr' substr$ )
107	3drop 0 ( 0 )
108	;
109
110	\ Skip over all occurences of specified characters at the beginning
111	\ of the string.
112	: string-skipchars ( str$ chars$ -- str$' )
113	2over bounds ?do ( str$ chars$ )
114	2dup i c@ strchr if ( str$ chars$ )
115	2swap 1 /string 2swap ( str$' chars$ )
116	else ( str$ chars$ )
117	leave ( str$ chars$ )
118	then ( str$ chars$ )
119	loop ( str$' chars$ )
120	2drop ( str$' )
121	;
122
123	\ Get the next token from the text string. Tokens are delimited by one
124	\ or more characters specified in the delimiter string.
125	: strtok ( text$ delim$ -- rem$ tok$ )
126	2swap 2over string-skipchars 2swap ( text$' delim$ )
127	2over bounds ?do ( text$' delim$ )
128	2dup i c@ strchr if ( text$' delim$ )
129	2drop i c@ left-parse-string unloop exit ( rem$ tok$ )
130	then ( text$' delim$ )
131	loop ( text$' delim$ )
132	2drop null$ 2swap ( null$ tok$ )
133	;
134
135	\ Split a string into 2 substrings.
136	: string-split ( adr len n -- adr+n len-n adr n )
137	>r 2dup r@ /string 2swap drop r>
138	;
139
140	\ Get contents of a quoted string.
141	: qdstring>string ( $ -- $' )
142	over c@ ascii " = if
143	1 /string ascii " left-parse-string 2swap 2drop
144	then
145	;
146
147	\ Concatenate strings.
148	: strcat ( adr1 len1 adr2 len2 -- adr1 len1+len2 )
149	2over 2over 2swap ca+ swap move nip +
150	;
151
152	\ Store string as a null-terminated string and return pointer past the
153	\ terminating null character.
154	: $cstrput ( str len dest-adr -- end-adr )
155	swap 2dup ca+ >r move 0 r@ c! r> ca1+
156	;
157
158	: cstrlen ( cstr -- length )
159	dup begin dup c@ while ca1+ repeat swap -
160	;
161
162	: cscount ( cstr -- adr len ) dup cstrlen ;
163
164	: upper ( adr len -- ) bounds ?do i dup c@ upc swap c! loop ;
165	: lower ( adr len -- ) bounds ?do i dup c@ lcc swap c! loop ;
166
167	d# 64 instance buffer: hexascii-buf
168
169	\ Get ASCII hexadecimal representation of octet stream
170	: octet-to-hexascii ( data datalen -- buf buflen )
171	hexascii-buf 0 2swap ( buf 0 data datalen )
172	dup 0= over d# 32 > or if ( buf 0 data datalen )
173	2drop exit ( buf 0 )
174	then ( buf 0 data datalen )
175	base @ >r hex ( buf 0 data datalen )
176	bounds ?do ( buf len )
177	i c@ <# u# u# u#> ( buf len $ )
178	2over ca+ swap move ( buf len )
179	2+ ( buf len' )
180	loop ( buf len' )
181	2dup upper ( buf len' )
182	r> base ! ( buf buflen )
183	;
184
185	\ Get octet stream representation of ASCII hexadecimal string
186	: hexascii-to-octet ( data datalen -- buf buflen )
187	hexascii-buf 0 2swap ( buf 0 data datalen )
188	dup 0= over d# 128 > or over 2 mod 0<> or if ( buf 0 data datalen )
189	2drop exit ( buf 0 )
190	then ( buf 0 data datalen )
191	bounds ?do ( buf len )
192	i 2 $hnumber if ( buf len )
193	drop 0 unloop exit ( buf 0 )
194	then ( buf len n )
195	>r 2dup ca+ r> swap c! ( buf len )
196	1+ ( buf len' )
197	2 +loop ( buf len' )
198	;
199
200	headers