1 /*
2 * s e a r c h . c
3 * Forth Inspired Command Language
4 * ANS Forth SEARCH and SEARCH-EXT word-set written in C
5 * Author: John Sadler (john_sadler@alum.mit.edu)
6 * Created: 6 June 2000
7 * $Id: search.c,v 1.10 2010/08/12 13:57:22 asau Exp $
8 */
9 /*
10 * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 * All rights reserved.
12 *
13 * Get the latest Ficl release at http://ficl.sourceforge.net
14 *
15 * I am interested in hearing from anyone who uses Ficl. If you have
16 * a problem, a success story, a defect, an enhancement request, or
17 * if you would like to contribute to the Ficl release, please
18 * contact me by email at the address above.
19 *
20 * L I C E N S E and D I S C L A I M E R
21 *
22 * Redistribution and use in source and binary forms, with or without
23 * modification, are permitted provided that the following conditions
24 * are met:
25 * 1. Redistributions of source code must retain the above copyright
26 * notice, this list of conditions and the following disclaimer.
27 * 2. Redistributions in binary form must reproduce the above copyright
28 * notice, this list of conditions and the following disclaimer in the
29 * documentation and/or other materials provided with the distribution.
30 *
31 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
32 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
33 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
34 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
35 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
36 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
37 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
38 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
39 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
41 * SUCH DAMAGE.
42 */
43
44 #include <string.h>
45 #include "ficl.h"
46
47 /*
48 * d e f i n i t i o n s
49 * SEARCH ( -- )
50 * Make the compilation word list the same as the first word list in the
51 * search order. Specifies that the names of subsequent definitions will
52 * be placed in the compilation word list. Subsequent changes in the search
53 * order will not affect the compilation word list.
54 */
55 static void
ficlPrimitiveDefinitions(ficlVm * vm)56 ficlPrimitiveDefinitions(ficlVm *vm)
57 {
58 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
59
60 FICL_VM_ASSERT(vm, dictionary);
61 if (dictionary->wordlistCount < 1) {
62 ficlVmThrowError(vm, "DEFINITIONS error - empty search order");
63 }
64
65 dictionary->compilationWordlist =
66 dictionary->wordlists[dictionary->wordlistCount-1];
67 }
68
69 /*
70 * f o r t h - w o r d l i s t
71 * SEARCH ( -- wid )
72 * Return wid, the identifier of the word list that includes all standard
73 * words provided by the implementation. This word list is initially the
74 * compilation word list and is part of the initial search order.
75 */
76 static void
ficlPrimitiveForthWordlist(ficlVm * vm)77 ficlPrimitiveForthWordlist(ficlVm *vm)
78 {
79 ficlHash *hash = ficlVmGetDictionary(vm)->forthWordlist;
80 ficlStackPushPointer(vm->dataStack, hash);
81 }
82
83
84 /*
85 * g e t - c u r r e n t
86 * SEARCH ( -- wid )
87 * Return wid, the identifier of the compilation word list.
88 */
89 static void
ficlPrimitiveGetCurrent(ficlVm * vm)90 ficlPrimitiveGetCurrent(ficlVm *vm)
91 {
92 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
93 ficlDictionaryLock(dictionary, FICL_TRUE);
94 ficlStackPushPointer(vm->dataStack, dictionary->compilationWordlist);
95 ficlDictionaryLock(dictionary, FICL_FALSE);
96 }
97
98 /*
99 * g e t - o r d e r
100 * SEARCH ( -- widn ... wid1 n )
101 * Returns the number of word lists n in the search order and the word list
102 * identifiers widn ... wid1 identifying these word lists. wid1 identifies
103 * the word list that is searched first, and widn the word list that is
104 * searched last. The search order is unaffected.
105 */
106 static void
ficlPrimitiveGetOrder(ficlVm * vm)107 ficlPrimitiveGetOrder(ficlVm *vm)
108 {
109 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
110 int wordlistCount = dictionary->wordlistCount;
111 int i;
112
113 ficlDictionaryLock(dictionary, FICL_TRUE);
114 for (i = 0; i < wordlistCount; i++) {
115 ficlStackPushPointer(vm->dataStack, dictionary->wordlists[i]);
116 }
117
118 ficlStackPushUnsigned(vm->dataStack, wordlistCount);
119 ficlDictionaryLock(dictionary, FICL_FALSE);
120 }
121
122 /*
123 * s e a r c h - w o r d l i s t
124 * SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
125 * Find the definition identified by the string c-addr u in the word list
126 * identified by wid. If the definition is not found, return zero. If the
127 * definition is found, return its execution token xt and one (1) if the
128 * definition is immediate, minus-one (-1) otherwise.
129 */
130 static void
ficlPrimitiveSearchWordlist(ficlVm * vm)131 ficlPrimitiveSearchWordlist(ficlVm *vm)
132 {
133 ficlString name;
134 ficlUnsigned16 hashCode;
135 ficlWord *word;
136 ficlHash *hash = ficlStackPopPointer(vm->dataStack);
137
138 name.length = (ficlUnsigned8)ficlStackPopUnsigned(vm->dataStack);
139 name.text = ficlStackPopPointer(vm->dataStack);
140 hashCode = ficlHashCode(name);
141
142 ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_TRUE);
143 word = ficlHashLookup(hash, name, hashCode);
144 ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_FALSE);
145
146 if (word) {
147 ficlStackPushPointer(vm->dataStack, word);
148 ficlStackPushInteger(vm->dataStack,
149 (ficlWordIsImmediate(word) ? 1 : -1));
150 } else {
151 ficlStackPushUnsigned(vm->dataStack, 0);
152 }
153 }
154
155 /*
156 * s e t - c u r r e n t
157 * SEARCH ( wid -- )
158 * Set the compilation word list to the word list identified by wid.
159 */
160 static void
ficlPrimitiveSetCurrent(ficlVm * vm)161 ficlPrimitiveSetCurrent(ficlVm *vm)
162 {
163 ficlHash *hash = ficlStackPopPointer(vm->dataStack);
164 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
165 ficlDictionaryLock(dictionary, FICL_TRUE);
166 dictionary->compilationWordlist = hash;
167 ficlDictionaryLock(dictionary, FICL_FALSE);
168 }
169
170 /*
171 * s e t - o r d e r
172 * SEARCH ( widn ... wid1 n -- )
173 * Set the search order to the word lists identified by widn ... wid1.
174 * Subsequently, word list wid1 will be searched first, and word list
175 * widn searched last. If n is zero, empty the search order. If n is minus
176 * one, set the search order to the implementation-defined minimum
177 * search order. The minimum search order shall include the words
178 * FORTH-WORDLIST and SET-ORDER. A system shall allow n to
179 * be at least eight.
180 */
181 static void
ficlPrimitiveSetOrder(ficlVm * vm)182 ficlPrimitiveSetOrder(ficlVm *vm)
183 {
184 int i;
185 int wordlistCount = ficlStackPopInteger(vm->dataStack);
186 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
187
188 if (wordlistCount > FICL_MAX_WORDLISTS) {
189 ficlVmThrowError(vm,
190 "set-order error: list would be too large");
191 }
192
193 ficlDictionaryLock(dictionary, FICL_TRUE);
194
195 if (wordlistCount >= 0) {
196 dictionary->wordlistCount = wordlistCount;
197 for (i = wordlistCount-1; i >= 0; --i) {
198 dictionary->wordlists[i] =
199 ficlStackPopPointer(vm->dataStack);
200 }
201 } else {
202 ficlDictionaryResetSearchOrder(dictionary);
203 }
204
205 ficlDictionaryLock(dictionary, FICL_FALSE);
206 }
207
208 /*
209 * f i c l - w o r d l i s t
210 * SEARCH ( -- wid )
211 * Create a new empty word list, returning its word list identifier wid.
212 * The new word list may be returned from a pool of preallocated word
213 * lists or may be dynamically allocated in data space. A system shall
214 * allow the creation of at least 8 new word lists in addition to any
215 * provided as part of the system.
216 * Notes:
217 * 1. Ficl creates a new single-list hash in the dictionary and returns
218 * its address.
219 * 2. ficl-wordlist takes an arg off the stack indicating the number of
220 * hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
221 * : wordlist 1 ficl-wordlist ;
222 */
223 static void
ficlPrimitiveFiclWordlist(ficlVm * vm)224 ficlPrimitiveFiclWordlist(ficlVm *vm)
225 {
226 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
227 ficlHash *hash;
228 ficlUnsigned nBuckets;
229
230 FICL_STACK_CHECK(vm->dataStack, 1, 1);
231
232 nBuckets = ficlStackPopUnsigned(vm->dataStack);
233 hash = ficlDictionaryCreateWordlist(dictionary, nBuckets);
234 ficlStackPushPointer(vm->dataStack, hash);
235 }
236
237 /*
238 * S E A R C H >
239 * Ficl ( -- wid )
240 * Pop wid off the search order. Error if the search order is empty
241 */
242 static void
ficlPrimitiveSearchPop(ficlVm * vm)243 ficlPrimitiveSearchPop(ficlVm *vm)
244 {
245 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
246 int wordlistCount;
247
248 ficlDictionaryLock(dictionary, FICL_TRUE);
249 wordlistCount = dictionary->wordlistCount;
250 if (wordlistCount == 0) {
251 ficlVmThrowError(vm, "search> error: empty search order");
252 }
253 ficlStackPushPointer(vm->dataStack,
254 dictionary->wordlists[--dictionary->wordlistCount]);
255 ficlDictionaryLock(dictionary, FICL_FALSE);
256 }
257
258 /*
259 * > S E A R C H
260 * Ficl ( wid -- )
261 * Push wid onto the search order. Error if the search order is full.
262 */
263 static void
ficlPrimitiveSearchPush(ficlVm * vm)264 ficlPrimitiveSearchPush(ficlVm *vm)
265 {
266 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
267
268 ficlDictionaryLock(dictionary, FICL_TRUE);
269 if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) {
270 ficlVmThrowError(vm, ">search error: search order overflow");
271 }
272 dictionary->wordlists[dictionary->wordlistCount++] =
273 ficlStackPopPointer(vm->dataStack);
274 ficlDictionaryLock(dictionary, FICL_FALSE);
275 }
276
277 /*
278 * W I D - G E T - N A M E
279 * Ficl ( wid -- c-addr u )
280 * Get wid's (optional) name and push onto stack as a counted string
281 */
282 static void
ficlPrimitiveWidGetName(ficlVm * vm)283 ficlPrimitiveWidGetName(ficlVm *vm)
284 {
285 ficlHash *hash;
286 char *name;
287 ficlInteger length;
288 ficlCell c;
289
290 hash = ficlVmPop(vm).p;
291 name = hash->name;
292
293 if (name != NULL)
294 length = strlen(name);
295 else
296 length = 0;
297
298 c.p = name;
299 ficlVmPush(vm, c);
300
301 c.i = length;
302 ficlVmPush(vm, c);
303 }
304
305 /*
306 * W I D - S E T - N A M E
307 * Ficl ( wid c-addr -- )
308 * Set wid's name pointer to the \0 terminated string address supplied
309 */
310 static void
ficlPrimitiveWidSetName(ficlVm * vm)311 ficlPrimitiveWidSetName(ficlVm *vm)
312 {
313 char *name = (char *)ficlVmPop(vm).p;
314 ficlHash *hash = ficlVmPop(vm).p;
315 hash->name = name;
316 }
317
318 /*
319 * setParentWid
320 * Ficl
321 * setparentwid ( parent-wid wid -- )
322 * Set WID's link field to the parent-wid. search-wordlist will
323 * iterate through all the links when finding words in the child wid.
324 */
325 static void
ficlPrimitiveSetParentWid(ficlVm * vm)326 ficlPrimitiveSetParentWid(ficlVm *vm)
327 {
328 ficlHash *parent, *child;
329
330 FICL_STACK_CHECK(vm->dataStack, 2, 0);
331
332 child = (ficlHash *)ficlStackPopPointer(vm->dataStack);
333 parent = (ficlHash *)ficlStackPopPointer(vm->dataStack);
334
335 child->link = parent;
336 }
337
338 /*
339 * f i c l C o m p i l e S e a r c h
340 * Builds the primitive wordset and the environment-query namespace.
341 */
342 void
ficlSystemCompileSearch(ficlSystem * system)343 ficlSystemCompileSearch(ficlSystem *system)
344 {
345 ficlDictionary *dictionary = ficlSystemGetDictionary(system);
346 ficlDictionary *environment = ficlSystemGetEnvironment(system);
347
348 FICL_SYSTEM_ASSERT(system, dictionary);
349 FICL_SYSTEM_ASSERT(system, environment);
350
351 /*
352 * optional SEARCH-ORDER word set
353 */
354 (void) ficlDictionarySetPrimitive(dictionary, ">search",
355 ficlPrimitiveSearchPush, FICL_WORD_DEFAULT);
356 (void) ficlDictionarySetPrimitive(dictionary, "search>",
357 ficlPrimitiveSearchPop, FICL_WORD_DEFAULT);
358 (void) ficlDictionarySetPrimitive(dictionary, "definitions",
359 ficlPrimitiveDefinitions, FICL_WORD_DEFAULT);
360 (void) ficlDictionarySetPrimitive(dictionary, "forth-wordlist",
361 ficlPrimitiveForthWordlist, FICL_WORD_DEFAULT);
362 (void) ficlDictionarySetPrimitive(dictionary, "get-current",
363 ficlPrimitiveGetCurrent, FICL_WORD_DEFAULT);
364 (void) ficlDictionarySetPrimitive(dictionary, "get-order",
365 ficlPrimitiveGetOrder, FICL_WORD_DEFAULT);
366 (void) ficlDictionarySetPrimitive(dictionary, "search-wordlist",
367 ficlPrimitiveSearchWordlist, FICL_WORD_DEFAULT);
368 (void) ficlDictionarySetPrimitive(dictionary, "set-current",
369 ficlPrimitiveSetCurrent, FICL_WORD_DEFAULT);
370 (void) ficlDictionarySetPrimitive(dictionary, "set-order",
371 ficlPrimitiveSetOrder, FICL_WORD_DEFAULT);
372 (void) ficlDictionarySetPrimitive(dictionary, "ficl-wordlist",
373 ficlPrimitiveFiclWordlist, FICL_WORD_DEFAULT);
374
375 /*
376 * Set SEARCH environment query values
377 */
378 (void) ficlDictionarySetConstant(environment, "search-order",
379 FICL_TRUE);
380 (void) ficlDictionarySetConstant(environment, "search-order-ext",
381 FICL_TRUE);
382 (void) ficlDictionarySetConstant(environment, "wordlists",
383 FICL_MAX_WORDLISTS);
384 (void) ficlDictionarySetPrimitive(dictionary, "wid-get-name",
385 ficlPrimitiveWidGetName, FICL_WORD_DEFAULT);
386 (void) ficlDictionarySetPrimitive(dictionary, "wid-set-name",
387 ficlPrimitiveWidSetName, FICL_WORD_DEFAULT);
388 (void) ficlDictionarySetPrimitive(dictionary, "wid-set-super",
389 ficlPrimitiveSetParentWid, FICL_WORD_DEFAULT);
390 }
391