/*
 * 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
         */
        (void) ficlDictionarySetPrimitive(dictionary, ">search",
            ficlPrimitiveSearchPush, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "search>",
            ficlPrimitiveSearchPop, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "definitions",
            ficlPrimitiveDefinitions, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "forth-wordlist",
            ficlPrimitiveForthWordlist, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "get-current",
            ficlPrimitiveGetCurrent, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "get-order",
            ficlPrimitiveGetOrder, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "search-wordlist",
            ficlPrimitiveSearchWordlist, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "set-current",
            ficlPrimitiveSetCurrent, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "set-order",
            ficlPrimitiveSetOrder, FICL_WORD_DEFAULT);
        (void) ficlDictionarySetPrimitive(dictionary, "ficl-wordlist",
            ficlPrimitiveFiclWordlist, FICL_WORD_DEFAULT);

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