| 1 | \ ========== Copyright Header Begin ========================================== |
| 2 | \ |
| 3 | \ Hypervisor Software File: tagvoc.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: @(#)tagvoc.fth 3.9 04/03/19 17:00:34 |
| 43 | purpose: |
| 44 | copyright: Copyright 1994-2002 Sun Microsystems, Inc. All Rights Reserved |
| 45 | copyright: Use is subject to license terms. |
| 46 | \ Copyright 1985-1994 Bradley Forthware |
| 47 | |
| 48 | \ Implementation of vocabularies. Vocabularies are lists of word names. |
| 49 | \ The following operations may be performed on vocabularies: |
| 50 | \ find-word - Search for a given word |
| 51 | \ "header - Create a new word in the "current" vocabulary |
| 52 | \ trim - Remove all words in a vocabulary created after an address |
| 53 | \ another? - Enumerate all the the words |
| 54 | \ |
| 55 | \ Each word name in a vocabulary has a byte with the following attributes: |
| 56 | \ name flag bit (7) - Identifies the byte as, indeed, belonging to a name |
| 57 | \ immediate flag bit (6) - Controls compilation of that word |
| 58 | \ alias flag bit (5) - Identifies the word as an alias |
| 59 | \ name-length bits (0-4) - Length of the name |
| 60 | |
| 61 | headers |
| 62 | |
| 63 | \ Find a potential name field address |
| 64 | : find-name ( acf -- anf ) >link l>name ; |
| 65 | |
| 66 | \ The test for a valid header searches backward to the position that |
| 67 | \ is expected to contain a name length byte. That byte is first checked |
| 68 | \ for the presence of the 'name-tag' (80) bit. Then the length is checked |
| 69 | \ to confirm that it is non-zero. Finally, the characters in the name |
| 70 | \ are checked to make sure that they are all non-blank and printable. |
| 71 | |
| 72 | : >name? ( acf -- anf good-name? ) |
| 73 | find-name ( anf ) |
| 74 | |
| 75 | \ Check for the name-flag bit |
| 76 | dup c@ h# 80 and dup if drop ( anf ) |
| 77 | |
| 78 | \ Check for zero-length name. |
| 79 | true over name>string ( anf true adr len ) |
| 80 | ?dup 0= if 2drop false exit then |
| 81 | |
| 82 | \ Check for bogus (blank or non-printable) characters. |
| 83 | bounds ?do ( anf true ) |
| 84 | i c@ bl 1+ h# 7e between 0= |
| 85 | if 0= leave then |
| 86 | loop ( anf good-name? ) |
| 87 | then |
| 88 | ; |
| 89 | |
| 90 | \ Address conversion operators |
| 91 | : n>link ( anf -- alf ) 1+ ; |
| 92 | : l>name ( alf -- anf ) 1- ; |
| 93 | : n>flags ( anf -- aff ) ; |
| 94 | : name> ( anf -- acf ) n>link link> ; |
| 95 | : link> ( alf -- acf ) /link + ; |
| 96 | : >link ( acf -- alf ) /link - ; |
| 97 | : >flags ( acf -- aff ) >name n>flags ; |
| 98 | : name>string ( anf -- adr len ) dup c@ h# 1f and tuck - swap ; |
| 99 | : l>beginning ( alf -- adr ) l>name name>string drop ; |
| 100 | : >threads ( acf -- ath ) >body >user ; |
| 101 | |
| 102 | nuser last |
| 103 | |
| 104 | headerless |
| 105 | |
| 106 | : $make-header ( adr len voc-acf -- ) |
| 107 | -rot ( voc-acf adr,len ) |
| 108 | dup 1+ /link + ( voc-acf adr,len hdr-len ) |
| 109 | |
| 110 | here + ( voc-acf adr,len addr' ) |
| 111 | dup acf-aligned swap - allot ( voc-acf adr,len ) |
| 112 | tuck here over 1+ note-string allot ( voc-acf len adr,len anf ) |
| 113 | place-cstr ( voc-acf len anf ) |
| 114 | over + c! ( voc-acf ) |
| 115 | here 1- last ! ( voc-acf ) |
| 116 | >threads ( threads-adr ) |
| 117 | /link allot here ( threads-adr acf ) |
| 118 | |
| 119 | swap 2dup link@ ( acf threads-adr acf succ-acf ) |
| 120 | swap >link link! link! ( ) |
| 121 | |
| 122 | last @ c@ h# 80 or last @ c! |
| 123 | ; |
| 124 | |
| 125 | headers |
| 126 | : >first ( voc-acf -- first-alf ) >threads ; |
| 127 | |
| 128 | [ifndef] XREF |
| 129 | : $find-word ( adr len voc-acf -- adr len [ false | xt,+-1 ] ) |
| 130 | >first $find-next find-fixup |
| 131 | ; |
| 132 | [else] |
| 133 | \ |
| 134 | \ Watchout the lose is patched with the acf of keys-forth later!! |
| 135 | \ |
| 136 | : $find-word ( adr len voc-acf -- adr len [ false | xt,+-1 ] ) |
| 137 | >r 2dup r@ >first $find-next find-fixup ( adr len [ adr,len,0 | xt,+-1 ] ) |
| 138 | dup if ( adr len xt,+-1 ) |
| 139 | 2swap ( xt,+-1 adr len ) |
| 140 | r> ['] lose <> ( xt,+-1 adr len xref? ) |
| 141 | if xref-find-hook then ( xt,+-1 adr len ) |
| 142 | 2drop ( xt,-+1 ) |
| 143 | else ( adr len adr,len,0 ) |
| 144 | r> drop >r 2swap 2drop r> ( adr,len,0 ) |
| 145 | then ( adr len [ false | xt,+-1 ] ) |
| 146 | ; |
| 147 | [then] |
| 148 | |
| 149 | headerless |
| 150 | : >ptr ( alf voc-acf -- ptr ) |
| 151 | over if drop else nip >threads then |
| 152 | ; |
| 153 | : next-word ( alf voc-acf -- false | alf' true ) |
| 154 | >ptr another-link? if >link true else false then |
| 155 | ; |
| 156 | : insert-word ( new-alf old-alf voc-ptr -- ) |
| 157 | >ptr ( new-alf alf ) |
| 158 | swap link> swap ( new-acf alf ) |
| 159 | 2dup link@ ( new-acf alf new-acf next-acf ) |
| 160 | swap >link link! link! |
| 161 | ; |
| 162 | |
| 163 | headers |
| 164 | \ |
| 165 | \ WARNING, the '>threads' in remove-word is patched by fm/kernel/hashcach.fth |
| 166 | \ |
| 167 | : remove-word ( new-alf voc-acf -- ) |
| 168 | >threads ( new-alf prev-link ) |
| 169 | swap link> swap link> ( new-acf prev-link ) |
| 170 | begin ( acf prev-link ) |
| 171 | >link |
| 172 | 2dup link@ = if ( acf prev-link ) |
| 173 | swap >link link@ swap link! exit ( ) |
| 174 | then ( acf prev-link ) |
| 175 | another-link? 0= ( acf [ next-link ] end? ) |
| 176 | until |
| 177 | drop |
| 178 | ; |
| 179 | |
| 180 | \ Makes a sealed vocabulary with the top-of-voc pointer in user area |
| 181 | \ parameter field of vocabularies contains: |
| 182 | \ user-#-of-voc-pointer , voc-link , |
| 183 | |
| 184 | \ For navigating inside a vocabulary's data structure. |
| 185 | \ A vocabulary's parameter field contains: |
| 186 | \ user# link |
| 187 | \ The threads are stored in the user area. |
| 188 | \ The link-field points to the preceding vocabulary. |
| 189 | \ |
| 190 | \ Historically, the pointer was the address of the link-field; |
| 191 | \ but in our current implementation, the pointer is the ACF. |
| 192 | |
| 193 | : voc> ( voc-link-adr -- acf ) |
| 194 | \ \ Comment-out the code to go from link-field to ACF, |
| 195 | \ \ in case we ever resurrect the old way. |
| 196 | \ /user# - body> |
| 197 | ; |
| 198 | |
| 199 | : >voc-link ( voc-acf -- voc-link-adr ) >body /user# + ; |
| 200 | |
| 201 | : (wordlist) ( -- ) |
| 202 | create-cf |
| 203 | /link user#, !null-link ( ) |
| 204 | voc-link, |
| 205 | 0 , \ Space for additional information |
| 206 | does> body> context token! |
| 207 | ; resolves <vocabulary> |
| 208 | headers |