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