Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: order.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: @(#)order.fth 2.13 03/12/11 09:22:49 | |
43 | purpose: | |
44 | copyright: Copyright 1990-2003 Sun Microsystems, Inc. All Rights Reserved | |
45 | copyright: Use is subject to license terms. | |
46 | \ Copyright 1985-1990 Bradley Forthware | |
47 | ||
48 | \ Search order. Maintains the list of vocabularies that are | |
49 | \ searched while interpreting Forth code. | |
50 | ||
51 | decimal | |
52 | 16 equ nvocs | |
53 | nvocs constant #vocs \ The # of vocabularies that can be in the search path | |
54 | ||
55 | nvocs /token-t * ualloc-t user context \ vocabulary searched first | |
56 | tuser current \ vocabulary which gets new definitions | |
57 | ||
58 | #vocs /token * constant /context | |
59 | : context-bounds ( -- end start ) context /context bounds ; | |
60 | ||
61 | headerless | |
62 | : shuffle-down ( adr -- finished? ) | |
63 | \ The loop goes from the next location after adr to the end of the | |
64 | \ context array. | |
65 | context-bounds drop over /token + ?do ( adr ) | |
66 | \ Look for a non-null entry, replace the current entry with that one, | |
67 | \ and replace that one with null | |
68 | i get-token? if ( adr acf ) | |
69 | over token! i !null-token leave ( adr ) | |
70 | then ( adr ) | |
71 | /token +loop | |
72 | drop | |
73 | ; | |
74 | headers | |
75 | : clear-context ( -- ) | |
76 | context-bounds ?do i !null-token /token +loop | |
77 | ; | |
78 | headerless | |
79 | : compact-search-order ( -- ) | |
80 | context-bounds ?do | |
81 | i get-token? 0= if i shuffle-down else drop then | |
82 | /token +loop | |
83 | ; | |
84 | headers | |
85 | : (except ( voc-acf -- ) \ Remove a vocabulary from the search order | |
86 | context-bounds ?do | |
87 | dup i token@ = if i !null-token then | |
88 | /token +loop | |
89 | drop compact-search-order | |
90 | ; | |
91 | ||
92 | nuser prior \ used for dictionary searches | |
93 | : $find ( adr len -- xt +-1 | adr len 0 ) | |
94 | 2dup 2>r | |
95 | $canonical ( adr' len' ) | |
96 | prior off ( adr len ) | |
97 | false ( adr len found? ) | |
98 | context-bounds ?do | |
99 | drop | |
100 | i get-token? if ( adr len voc ) | |
101 | ||
102 | \ Don't search the vocabulary again if we just searched it. | |
103 | dup prior @ over prior ! = if ( adr len voc ) | |
104 | drop false ( adr len false ) | |
105 | else ( adr len voc ) | |
106 | $find-word dup ?leave ( adr len false ) | |
107 | then ( adr len false ) | |
108 | ||
109 | else ( adr len voc ) | |
110 | false ( adr len false ) | |
111 | then ( adr len false ) | |
112 | /token +loop ( adr len false | xt +-1 ) | |
113 | ?dup if | |
114 | 2r> 2drop | |
115 | else | |
116 | 2drop 2r> false | |
117 | then | |
118 | ; | |
119 | : find ( pstr -- pstr false | xt +-1 ) | |
120 | dup >r count $find dup 0= if nip nip r> swap else r> drop then | |
121 | ; | |
122 | ||
123 | \ The also/only vocabulary search order scheme | |
124 | ||
125 | decimal | |
126 | : >voc ( n -- adr ) /token * context + ; | |
127 | ||
128 | vocabulary root root definitions-t | |
129 | ||
130 | : also ( -- ) context 1 >voc #vocs 2- /token * cmove> ; | |
131 | ||
132 | : (min-search) root also re-heads also ; | |
133 | defer minimum-search-order ' (min-search) is minimum-search-order | |
134 | : forth-wordlist ( -- wid ) ['] forth ; | |
135 | : get-current ( -- ) current token@ ; | |
136 | : set-current ( -- ) current token! ; | |
137 | ||
138 | : get-order ( -- vocn .. voc1 n ) | |
139 | 0 0 #vocs 1- do | |
140 | i >voc token@ non-null? if swap 1+ then | |
141 | -1 +loop | |
142 | ; | |
143 | : set-order ( vocn .. voc1 n -- ) | |
144 | dup #vocs > abort" Too many vocabularies in requested search order" | |
145 | clear-context | |
146 | 0 ?do i >voc token! loop | |
147 | ; | |
148 | ||
149 | : only ( -- ) | |
150 | clear-context | |
151 | \ ['] root #vocs 1- >voc token! | |
152 | minimum-search-order | |
153 | ; | |
154 | ||
155 | : except \ vocabulary-name ( -- ) | |
156 | ' (except | |
157 | ; | |
158 | : seal ( -- ) ['] root (except ; | |
159 | : previous ( -- ) | |
160 | 1 >voc context #vocs 2- /token * cmove | |
161 | #vocs 2- >voc !null-token | |
162 | ; | |
163 | ||
164 | : definitions ( -- ) context token@ set-current ; | |
165 | ||
166 | : order ( -- ) | |
167 | ." context: " | |
168 | get-order 0 ?do .name loop | |
169 | 4 spaces ." current: " get-current .name | |
170 | ; | |
171 | : vocs ( -- ) | |
172 | voc-link begin another-link? while ( link ) | |
173 | #out @ 64 > if cr then | |
174 | dup voc> .name | |
175 | >voc-link | |
176 | repeat | |
177 | ; | |
178 | ||
179 | vocabulary forth forth definitions-t | |
180 | ||
181 | \ only forth also definitions | |
182 | \ : (cold-hook ( -- ) (cold-hook only forth also definitions ; | |
183 | \ headers | |
184 | ||
185 | chain: init ( -- ) only forth also definitions ; | |
186 | ||
187 | \ "Hidden" is a vocabulary that can be used to contain implementation words | |
188 | \ that shouldn't appear in the forth dictionary. It was popular before we | |
189 | \ had the option to compile such words headerless (and also save space). | |
190 | \ Headerless words made the decompiler less useful, so we added a way for | |
191 | \ developers to restore headerful behavior | |
192 | ||
193 | vocabulary hidden hidden definitions-t | |
194 | ||
195 | \ "Re-heads" is the vocabulary that will hold restored headers and make them | |
196 | \ searchable to the decompiler. It will be somewhat of a while before we | |
197 | \ actually use it, but we need it defined now so that we can get it into the | |
198 | \ search-order early on in the game. | |
199 | ||
200 | vocabulary re-heads | |
201 | ||
202 | forth definitions-t |