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.9 2001/12/05 07:21:34 jsadler 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/* $FreeBSD$ */
45
46#include <string.h>
47#include "ficl.h"
48#include "math64.h"
49
50/**************************************************************************
51                        d e f i n i t i o n s
52** SEARCH ( -- )
53** Make the compilation word list the same as the first word list in the
54** search order. Specifies that the names of subsequent definitions will
55** be placed in the compilation word list. Subsequent changes in the search
56** order will not affect the compilation word list.
57**************************************************************************/
58static void definitions(FICL_VM *pVM)
59{
60    FICL_DICT *pDict = vmGetDict(pVM);
61
62    assert(pDict);
63    if (pDict->nLists < 1)
64    {
65        vmThrowErr(pVM, "DEFINITIONS error - empty search order");
66    }
67
68    pDict->pCompile = pDict->pSearch[pDict->nLists-1];
69    return;
70}
71
72
73/**************************************************************************
74                        f o r t h - w o r d l i s t
75** SEARCH ( -- wid )
76** Return wid, the identifier of the word list that includes all standard
77** words provided by the implementation. This word list is initially the
78** compilation word list and is part of the initial search order.
79**************************************************************************/
80static void forthWordlist(FICL_VM *pVM)
81{
82    FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
83    stackPushPtr(pVM->pStack, pHash);
84    return;
85}
86
87
88/**************************************************************************
89                        g e t - c u r r e n t
90** SEARCH ( -- wid )
91** Return wid, the identifier of the compilation word list.
92**************************************************************************/
93static void getCurrent(FICL_VM *pVM)
94{
95    ficlLockDictionary(TRUE);
96    stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile);
97    ficlLockDictionary(FALSE);
98    return;
99}
100
101
102/**************************************************************************
103                        g e t - o r d e r
104** SEARCH ( -- widn ... wid1 n )
105** Returns the number of word lists n in the search order and the word list
106** identifiers widn ... wid1 identifying these word lists. wid1 identifies
107** the word list that is searched first, and widn the word list that is
108** searched last. The search order is unaffected.
109**************************************************************************/
110static void getOrder(FICL_VM *pVM)
111{
112    FICL_DICT *pDict = vmGetDict(pVM);
113    int nLists = pDict->nLists;
114    int i;
115
116    ficlLockDictionary(TRUE);
117    for (i = 0; i < nLists; i++)
118    {
119        stackPushPtr(pVM->pStack, pDict->pSearch[i]);
120    }
121
122    stackPushUNS(pVM->pStack, nLists);
123    ficlLockDictionary(FALSE);
124    return;
125}
126
127
128/**************************************************************************
129                        s e a r c h - w o r d l i s t
130** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
131** Find the definition identified by the string c-addr u in the word list
132** identified by wid. If the definition is not found, return zero. If the
133** definition is found, return its execution token xt and one (1) if the
134** definition is immediate, minus-one (-1) otherwise.
135**************************************************************************/
136static void searchWordlist(FICL_VM *pVM)
137{
138    STRINGINFO si;
139    UNS16 hashCode;
140    FICL_WORD *pFW;
141    FICL_HASH *pHash = stackPopPtr(pVM->pStack);
142
143    si.count         = (FICL_COUNT)stackPopUNS(pVM->pStack);
144    si.cp            = stackPopPtr(pVM->pStack);
145    hashCode         = hashHashCode(si);
146
147    ficlLockDictionary(TRUE);
148    pFW = hashLookup(pHash, si, hashCode);
149    ficlLockDictionary(FALSE);
150
151    if (pFW)
152    {
153        stackPushPtr(pVM->pStack, pFW);
154        stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
155    }
156    else
157    {
158        stackPushUNS(pVM->pStack, 0);
159    }
160
161    return;
162}
163
164
165/**************************************************************************
166                        s e t - c u r r e n t
167** SEARCH ( wid -- )
168** Set the compilation word list to the word list identified by wid.
169**************************************************************************/
170static void setCurrent(FICL_VM *pVM)
171{
172    FICL_HASH *pHash = stackPopPtr(pVM->pStack);
173    FICL_DICT *pDict = vmGetDict(pVM);
174    ficlLockDictionary(TRUE);
175    pDict->pCompile = pHash;
176    ficlLockDictionary(FALSE);
177    return;
178}
179
180
181/**************************************************************************
182                        s e t - o r d e r
183** SEARCH ( widn ... wid1 n -- )
184** Set the search order to the word lists identified by widn ... wid1.
185** Subsequently, word list wid1 will be searched first, and word list
186** widn searched last. If n is zero, empty the search order. If n is minus
187** one, set the search order to the implementation-defined minimum
188** search order. The minimum search order shall include the words
189** FORTH-WORDLIST and SET-ORDER. A system shall allow n to
190** be at least eight.
191**************************************************************************/
192static void setOrder(FICL_VM *pVM)
193{
194    int i;
195    int nLists = stackPopINT(pVM->pStack);
196    FICL_DICT *dp = vmGetDict(pVM);
197
198    if (nLists > FICL_DEFAULT_VOCS)
199    {
200        vmThrowErr(pVM, "set-order error: list would be too large");
201    }
202
203    ficlLockDictionary(TRUE);
204
205    if (nLists >= 0)
206    {
207        dp->nLists = nLists;
208        for (i = nLists-1; i >= 0; --i)
209        {
210            dp->pSearch[i] = stackPopPtr(pVM->pStack);
211        }
212    }
213    else
214    {
215        dictResetSearchOrder(dp);
216    }
217
218    ficlLockDictionary(FALSE);
219    return;
220}
221
222
223/**************************************************************************
224                        f i c l - w o r d l i s t
225** SEARCH ( -- wid )
226** Create a new empty word list, returning its word list identifier wid.
227** The new word list may be returned from a pool of preallocated word
228** lists or may be dynamically allocated in data space. A system shall
229** allow the creation of at least 8 new word lists in addition to any
230** provided as part of the system.
231** Notes:
232** 1. ficl creates a new single-list hash in the dictionary and returns
233**    its address.
234** 2. ficl-wordlist takes an arg off the stack indicating the number of
235**    hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
236**    : wordlist 1 ficl-wordlist ;
237**************************************************************************/
238static void ficlWordlist(FICL_VM *pVM)
239{
240    FICL_DICT *dp = vmGetDict(pVM);
241    FICL_HASH *pHash;
242    FICL_UNS nBuckets;
243
244#if FICL_ROBUST > 1
245    vmCheckStack(pVM, 1, 1);
246#endif
247    nBuckets = stackPopUNS(pVM->pStack);
248    pHash = dictCreateWordlist(dp, nBuckets);
249    stackPushPtr(pVM->pStack, pHash);
250    return;
251}
252
253
254/**************************************************************************
255                        S E A R C H >
256** ficl  ( -- wid )
257** Pop wid off the search order. Error if the search order is empty
258**************************************************************************/
259static void searchPop(FICL_VM *pVM)
260{
261    FICL_DICT *dp = vmGetDict(pVM);
262    int nLists;
263
264    ficlLockDictionary(TRUE);
265    nLists = dp->nLists;
266    if (nLists == 0)
267    {
268        vmThrowErr(pVM, "search> error: empty search order");
269    }
270    stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
271    ficlLockDictionary(FALSE);
272    return;
273}
274
275
276/**************************************************************************
277                        > S E A R C H
278** ficl  ( wid -- )
279** Push wid onto the search order. Error if the search order is full.
280**************************************************************************/
281static void searchPush(FICL_VM *pVM)
282{
283    FICL_DICT *dp = vmGetDict(pVM);
284
285    ficlLockDictionary(TRUE);
286    if (dp->nLists > FICL_DEFAULT_VOCS)
287    {
288        vmThrowErr(pVM, ">search error: search order overflow");
289    }
290    dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
291    ficlLockDictionary(FALSE);
292    return;
293}
294
295
296/**************************************************************************
297                        W I D - G E T - N A M E
298** ficl  ( wid -- c-addr u )
299** Get wid's (optional) name and push onto stack as a counted string
300**************************************************************************/
301static void widGetName(FICL_VM *pVM)
302{
303    FICL_HASH *pHash = vmPop(pVM).p;
304    char *cp = pHash->name;
305    FICL_INT len = 0;
306
307    if (cp)
308        len = strlen(cp);
309
310    vmPush(pVM, LVALUEtoCELL(cp));
311    vmPush(pVM, LVALUEtoCELL(len));
312    return;
313}
314
315/**************************************************************************
316                        W I D - S E T - N A M E
317** ficl  ( wid c-addr -- )
318** Set wid's name pointer to the \0 terminated string address supplied
319**************************************************************************/
320static void widSetName(FICL_VM *pVM)
321{
322    char *cp = (char *)vmPop(pVM).p;
323    FICL_HASH *pHash = vmPop(pVM).p;
324    pHash->name = cp;
325    return;
326}
327
328
329/**************************************************************************
330                        setParentWid
331** FICL
332** setparentwid   ( parent-wid wid -- )
333** Set WID's link field to the parent-wid. search-wordlist will
334** iterate through all the links when finding words in the child wid.
335**************************************************************************/
336static void setParentWid(FICL_VM *pVM)
337{
338    FICL_HASH *parent, *child;
339#if FICL_ROBUST > 1
340    vmCheckStack(pVM, 2, 0);
341#endif
342    child  = (FICL_HASH *)stackPopPtr(pVM->pStack);
343    parent = (FICL_HASH *)stackPopPtr(pVM->pStack);
344
345    child->link = parent;
346    return;
347}
348
349
350/**************************************************************************
351                        f i c l C o m p i l e S e a r c h
352** Builds the primitive wordset and the environment-query namespace.
353**************************************************************************/
354
355void ficlCompileSearch(FICL_SYSTEM *pSys)
356{
357    FICL_DICT *dp = pSys->dp;
358    assert (dp);
359
360    /*
361    ** optional SEARCH-ORDER word set
362    */
363    dictAppendWord(dp, ">search",   searchPush,     FW_DEFAULT);
364    dictAppendWord(dp, "search>",   searchPop,      FW_DEFAULT);
365    dictAppendWord(dp, "definitions",
366                                    definitions,    FW_DEFAULT);
367    dictAppendWord(dp, "forth-wordlist",
368                                    forthWordlist,  FW_DEFAULT);
369    dictAppendWord(dp, "get-current",
370                                    getCurrent,     FW_DEFAULT);
371    dictAppendWord(dp, "get-order", getOrder,       FW_DEFAULT);
372    dictAppendWord(dp, "search-wordlist",
373                                    searchWordlist, FW_DEFAULT);
374    dictAppendWord(dp, "set-current",
375                                    setCurrent,     FW_DEFAULT);
376    dictAppendWord(dp, "set-order", setOrder,       FW_DEFAULT);
377    dictAppendWord(dp, "ficl-wordlist",
378                                    ficlWordlist,   FW_DEFAULT);
379
380    /*
381    ** Set SEARCH environment query values
382    */
383    ficlSetEnv(pSys, "search-order",      FICL_TRUE);
384    ficlSetEnv(pSys, "search-order-ext",  FICL_TRUE);
385    ficlSetEnv(pSys, "wordlists",         FICL_DEFAULT_VOCS);
386
387    dictAppendWord(dp, "wid-get-name", widGetName,  FW_DEFAULT);
388    dictAppendWord(dp, "wid-set-name", widSetName,  FW_DEFAULT);
389    dictAppendWord(dp, "wid-set-super",
390                                    setParentWid,   FW_DEFAULT);
391    return;
392}
393
394