common/ficl/search.c

/*
 * s e a r c h . c
 * Forth Inspired Command Language
 * ANS Forth SEARCH and SEARCH-EXT word-set written in C
 * Author: John Sadler (john_sadler@alum.mit.edu)
 * Created: 6 June 2000
 * $Id: search.c,v 1.10 2010/08/12 13:57:22 asau Exp $
 */
/*
 * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
 * All rights reserved.
 *
 * Get the latest Ficl release at http://ficl.sourceforge.net
 *
 * I am interested in hearing from anyone who uses Ficl. If you have
 * a problem, a success story, a defect, an enhancement request, or
 * if you would like to contribute to the Ficl release, please
 * contact me by email at the address above.
 *
 * L I C E N S E  and  D I S C L A I M E R
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

#include <string.h>
#include "ficl.h"

/*
 * d e f i n i t i o n s
 * SEARCH ( -- )
 * Make the compilation word list the same as the first word list in the
 * search order. Specifies that the names of subsequent definitions will
 * be placed in the compilation word list. Subsequent changes in the search
 * order will not affect the compilation word list.
 */
static void
ficlPrimitiveDefinitions(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    FICL_VM_ASSERT(vm, dictionary);
    if (dictionary->wordlistCount < 1) {
        ficlVmThrowError(vm, "DEFINITIONS error - empty search order");
    }

    dictionary->compilationWordlist =
        dictionary->wordlists[dictionary->wordlistCount-1];
}

/*
 * f o r t h - w o r d l i s t
 * SEARCH ( -- wid )
 * Return wid, the identifier of the word list that includes all standard
 * words provided by the implementation. This word list is initially the
 * compilation word list and is part of the initial search order.
 */
static void
ficlPrimitiveForthWordlist(ficlVm *vm)
{
    ficlHash *hash = ficlVmGetDictionary(vm)->forthWordlist;
    ficlStackPushPointer(vm->dataStack, hash);
}


/*
 * g e t - c u r r e n t
 * SEARCH ( -- wid )
 * Return wid, the identifier of the compilation word list.
 */
static void
ficlPrimitiveGetCurrent(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlDictionaryLock(dictionary, FICL_TRUE);
    ficlStackPushPointer(vm->dataStack, dictionary->compilationWordlist);
    ficlDictionaryLock(dictionary, FICL_FALSE);
}

/*
 * g e t - o r d e r
 * SEARCH ( -- widn ... wid1 n )
 * Returns the number of word lists n in the search order and the word list
 * identifiers widn ... wid1 identifying these word lists. wid1 identifies
 * the word list that is searched first, and widn the word list that is
 * searched last. The search order is unaffected.
 */
static void
ficlPrimitiveGetOrder(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    int wordlistCount = dictionary->wordlistCount;
    int i;

    ficlDictionaryLock(dictionary, FICL_TRUE);
    for (i = 0; i < wordlistCount; i++) {
        ficlStackPushPointer(vm->dataStack, dictionary->wordlists[i]);
    }

    ficlStackPushUnsigned(vm->dataStack, wordlistCount);
    ficlDictionaryLock(dictionary, FICL_FALSE);
}

/*
 * s e a r c h - w o r d l i s t
 * SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
 * Find the definition identified by the string c-addr u in the word list
 * identified by wid. If the definition is not found, return zero. If the
 * definition is found, return its execution token xt and one (1) if the
 * definition is immediate, minus-one (-1) otherwise.
 */
static void
ficlPrimitiveSearchWordlist(ficlVm *vm)
{
    ficlString name;
    ficlUnsigned16 hashCode;
    ficlWord *word;
    ficlHash *hash = ficlStackPopPointer(vm->dataStack);

    name.length = (ficlUnsigned8)ficlStackPopUnsigned(vm->dataStack);
    name.text = ficlStackPopPointer(vm->dataStack);
    hashCode = ficlHashCode(name);

    ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_TRUE);
    word = ficlHashLookup(hash, name, hashCode);
    ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_FALSE);

    if (word) {
        ficlStackPushPointer(vm->dataStack, word);
        ficlStackPushInteger(vm->dataStack,
            (ficlWordIsImmediate(word) ? 1 : -1));
    } else {
        ficlStackPushUnsigned(vm->dataStack, 0);
    }
}

/*
 * s e t - c u r r e n t
 * SEARCH ( wid -- )
 * Set the compilation word list to the word list identified by wid.
 */
static void
ficlPrimitiveSetCurrent(ficlVm *vm)
{
    ficlHash *hash = ficlStackPopPointer(vm->dataStack);
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlDictionaryLock(dictionary, FICL_TRUE);
    dictionary->compilationWordlist = hash;
    ficlDictionaryLock(dictionary, FICL_FALSE);
}

/*
 *                      s e t - o r d e r
 * SEARCH ( widn ... wid1 n -- )
 * Set the search order to the word lists identified by widn ... wid1.
 * Subsequently, word list wid1 will be searched first, and word list
 * widn searched last. If n is zero, empty the search order. If n is minus
 * one, set the search order to the implementation-defined minimum
 * search order. The minimum search order shall include the words
 * FORTH-WORDLIST and SET-ORDER. A system shall allow n to
 * be at least eight.
 */
static void
ficlPrimitiveSetOrder(ficlVm *vm)
{
    int i;
    int wordlistCount = ficlStackPopInteger(vm->dataStack);
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    if (wordlistCount > FICL_MAX_WORDLISTS) {
        ficlVmThrowError(vm,
            "set-order error: list would be too large");
    }

    ficlDictionaryLock(dictionary, FICL_TRUE);

    if (wordlistCount >= 0) {
        dictionary->wordlistCount = wordlistCount;
        for (i = wordlistCount-1; i >= 0; --i) {
            dictionary->wordlists[i] =
                ficlStackPopPointer(vm->dataStack);
        }
    } else {
        ficlDictionaryResetSearchOrder(dictionary);
    }

    ficlDictionaryLock(dictionary, FICL_FALSE);
}

/*
 * f i c l - w o r d l i s t
 * SEARCH ( -- wid )
 * Create a new empty word list, returning its word list identifier wid.
 * The new word list may be returned from a pool of preallocated word
 * lists or may be dynamically allocated in data space. A system shall
 * allow the creation of at least 8 new word lists in addition to any
 * provided as part of the system.
 * Notes:
 * 1. Ficl creates a new single-list hash in the dictionary and returns
 *    its address.
 * 2. ficl-wordlist takes an arg off the stack indicating the number of
 *    hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
 *    : wordlist 1 ficl-wordlist ;
 */
static void
ficlPrimitiveFiclWordlist(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlHash *hash;
    ficlUnsigned nBuckets;

    FICL_STACK_CHECK(vm->dataStack, 1, 1);

    nBuckets = ficlStackPopUnsigned(vm->dataStack);
    hash = ficlDictionaryCreateWordlist(dictionary, nBuckets);
    ficlStackPushPointer(vm->dataStack, hash);
}

/*
 * S E A R C H >
 * Ficl  ( -- wid )
 * Pop wid off the search order. Error if the search order is empty
 */
static void
ficlPrimitiveSearchPop(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    int wordlistCount;

    ficlDictionaryLock(dictionary, FICL_TRUE);
    wordlistCount = dictionary->wordlistCount;
    if (wordlistCount == 0) {
        ficlVmThrowError(vm, "search> error: empty search order");
    }
    ficlStackPushPointer(vm->dataStack,
        dictionary->wordlists[--dictionary->wordlistCount]);
    ficlDictionaryLock(dictionary, FICL_FALSE);
}

/*
 * > S E A R C H
 * Ficl  ( wid -- )
 * Push wid onto the search order. Error if the search order is full.
 */
static void
ficlPrimitiveSearchPush(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);

    ficlDictionaryLock(dictionary, FICL_TRUE);
    if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) {
        ficlVmThrowError(vm, ">search error: search order overflow");
    }
    dictionary->wordlists[dictionary->wordlistCount++] =
        ficlStackPopPointer(vm->dataStack);
    ficlDictionaryLock(dictionary, FICL_FALSE);
}

/*
 * W I D - G E T - N A M E
 * Ficl  ( wid -- c-addr u )
 * Get wid's (optional) name and push onto stack as a counted string
 */
static void
ficlPrimitiveWidGetName(ficlVm *vm)
{
    ficlHash *hash;
    char *name;
    ficlInteger length;
    ficlCell c;

    hash = ficlVmPop(vm).p;
    name = hash->name;

    if (name != NULL)
        length = strlen(name);
    else
        length = 0;

    c.p = name;
    ficlVmPush(vm, c);

    c.i = length;
    ficlVmPush(vm, c);
}

/*
 * W I D - S E T - N A M E
 * Ficl  ( wid c-addr -- )
 * Set wid's name pointer to the \0 terminated string address supplied
 */
static void
ficlPrimitiveWidSetName(ficlVm *vm)
{
    char *name = (char *)ficlVmPop(vm).p;
    ficlHash *hash = ficlVmPop(vm).p;
    hash->name = name;
}

/*
 * setParentWid
 * Ficl
 * setparentwid   ( parent-wid wid -- )
 * Set WID's link field to the parent-wid. search-wordlist will
 * iterate through all the links when finding words in the child wid.
 */
static void
ficlPrimitiveSetParentWid(ficlVm *vm)
{
    ficlHash *parent, *child;

    FICL_STACK_CHECK(vm->dataStack, 2, 0);

    child  = (ficlHash *)ficlStackPopPointer(vm->dataStack);
    parent = (ficlHash *)ficlStackPopPointer(vm->dataStack);

    child->link = parent;
}

/*
 * f i c l C o m p i l e S e a r c h
 * Builds the primitive wordset and the environment-query namespace.
 */
void
ficlSystemCompileSearch(ficlSystem *system)
{
    ficlDictionary *dictionary = ficlSystemGetDictionary(system);
    ficlDictionary *environment = ficlSystemGetEnvironment(system);

    FICL_SYSTEM_ASSERT(system, dictionary);
    FICL_SYSTEM_ASSERT(system, environment);

    /*
     * optional SEARCH-ORDER word set
     */
    ficlDictionarySetPrimitive(dictionary, ">search",
        ficlPrimitiveSearchPush, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "search>",
        ficlPrimitiveSearchPop, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "definitions",
        ficlPrimitiveDefinitions, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "forth-wordlist",
        ficlPrimitiveForthWordlist, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "get-current",
        ficlPrimitiveGetCurrent, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "get-order",
        ficlPrimitiveGetOrder, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "search-wordlist",
        ficlPrimitiveSearchWordlist, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "set-current",
        ficlPrimitiveSetCurrent, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "set-order",
        ficlPrimitiveSetOrder, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "ficl-wordlist",
        ficlPrimitiveFiclWordlist, FICL_WORD_DEFAULT);

    /*
     * Set SEARCH environment query values
     */
    ficlDictionarySetConstant(environment, "search-order", FICL_TRUE);
    ficlDictionarySetConstant(environment, "search-order-ext", FICL_TRUE);
    ficlDictionarySetConstant(environment, "wordlists", FICL_MAX_WORDLISTS);
    ficlDictionarySetPrimitive(dictionary, "wid-get-name",
        ficlPrimitiveWidGetName, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "wid-set-name",
        ficlPrimitiveWidSetName, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "wid-set-super",
        ficlPrimitiveSetParentWid, FICL_WORD_DEFAULT);
}