StarForth/src/word_source/vocabulary_words.c

/*
  StarForth — Steady-State Virtual Machine Runtime

  Copyright (c) 2023–2025 Robert A. James
  All rights reserved.

  This file is part of the StarForth project.

  Licensed under the StarForth License, Version 1.0 (the "License");
  you may not use this file except in compliance with the License.

  You may obtain a copy of the License at:
      https://github.com/star.4th@proton.me/StarForth/LICENSE.txt

  This software is provided "AS IS", WITHOUT WARRANTY OF ANY KIND,
  express or implied, including but not limited to the warranties of
  merchantability, fitness for a particular purpose, and noninfringement.

 See the License for the specific language governing permissions and
 limitations under the License.

 StarForth — Steady-State Virtual Machine Runtime
  Copyright (c) 2023–2025 Robert A. James
  All rights reserved.

  This file is part of the StarForth project.

  Licensed under the StarForth License, Version 1.0 (the "License");
  you may not use this file except in compliance with the License.

  You may obtain a copy of the License at:
       https://github.com/star.4th@proton.me/StarForth/LICENSE.txt

  This software is provided "AS IS", WITHOUT WARRANTY OF ANY KIND,
  express or implied, including but not limited to the warranties of
  merchantability, fitness for a particular purpose, and noninfringement.

  See the License for the specific language governing permissions and
  limitations under the License.

 */

#include "include/vocabulary_words.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
#include "../../include/vm.h"
#include <string.h>
#include <stdio.h>
#include <stdlib.h>
#ifdef __STARKERNEL__
#include "starkernel/console.h"
#include "starkernel/hal/hal.h"
#include "starkernel/vm/arena.h"

/* Forward declaration for canonical check */
static inline int sf_is_canonical(uint64_t addr) {
    int64_t saddr = (int64_t)addr;
    return (saddr >> 47) == 0 || (saddr >> 47) == -1;
}
#endif

#if defined(__STARKERNEL__) && SK_PARITY_DEBUG
static void vocabulary_debug_print_hex(uint64_t value) __attribute__((unused));
static void vocabulary_debug_print_hex(uint64_t value)
{
    char buf[19];
    buf[0] = '0';
    buf[1] = 'x';
    buf[18] = '\0';
    for (int i = 0; i < 16; ++i) {
        uint8_t nibble = (uint8_t)((value >> ((15 - i) * 4)) & 0xF);
        buf[i + 2] = (nibble < 10) ? (char)('0' + nibble) : (char)('a' + nibble - 10);
    }
    console_puts(buf);
}
#else
static void vocabulary_debug_print_hex(uint64_t value) __attribute__((unused));
static void vocabulary_debug_print_hex(uint64_t value) {
    (void)value;
}
#endif

static size_t vocab_safe_len(const char *text, size_t max_len)
{
    size_t len = 0;
    if (!text) return 0;
    while (len < max_len && text[len] != '\0') {
        len++;
    }
    return len;
}


/* ---- first-character index for vocab chains (lazy rebuild) ----
 * Bucket arrays themselves live per-VM (VM.vocab.ctx_fc / .forth_fc,
 * declared in include/vm.h as VocabularyState); these two helpers just
 * operate on whichever VM's arrays are passed in. */

static void fc_free(DictEntry ***lists, size_t *counts) {
    for (size_t i = 0; i < VOCAB_FC_BUCKETS; ++i) {
        free(lists[i]);
        lists[i] = NULL;
        counts[i] = 0;
    }
}

static void fc_rebuild(DictEntry *head, DictEntry ***lists, size_t *counts, DictEntry **cached_head) {
    fc_free(lists, counts);

    /* first pass: counts */
    for (DictEntry *e = head; e; e = e->link) {
        unsigned c = (unsigned char) e->name[0];
        counts[c]++;
    }
    /* alloc */
    for (size_t i = 0; i < VOCAB_FC_BUCKETS; ++i) {
        if (counts[i]) {
            lists[i] = (DictEntry **) malloc(counts[i] * sizeof(DictEntry *));
            if (!lists[i]) counts[i] = 0; /* malloc failed: zero count so fill skips */
        }
    }
    /* second pass: fill oldest→newest (we’ll search newest-first by iterating backwards) */
    size_t filled[VOCAB_FC_BUCKETS] = {0};
    for (DictEntry *e = head; e; e = e->link) {
        unsigned c = (unsigned char) e->name[0];
        if (lists[c]) lists[c][filled[c]++] = e; /* skip null buckets */
    }
    *cached_head = head;
}

/* ===== FORTH-79 vocabulary model =====
   - CONTEXT: vocabulary searched first
   - then FORTH (system vocabulary) is searched
   - CURRENT: where new words are entered (DEFINITIONS: CURRENT := CONTEXT)
   - No ALSO/ONLY/PREVIOUS here. Period.
*/

/* Sync host state -> VM cells */
static inline void vocab_sync_vm_vars(VM *vm) {
    if (!vm->vocab.context_var_addr || !vm->vocab.current_var_addr) return;
#if defined(__STARKERNEL__) && SK_PARITY_DEBUG
    uint64_t cv = (uint64_t)(uintptr_t)vm->vocab.context_vocab;
    uint64_t rv = (uint64_t)(uintptr_t)vm->vocab.current_vocab;
    uint64_t base = (uintptr_t)vm->memory;

    console_puts("[VOC_SYNC] context=");
    vocabulary_debug_print_hex(cv);
    console_puts(" current=");
    vocabulary_debug_print_hex(rv);
    console_puts(" context_addr=");
    vocabulary_debug_print_hex((uint64_t)vm->vocab.context_var_addr);
    console_puts(" current_addr=");
    vocabulary_debug_print_hex((uint64_t)vm->vocab.current_var_addr);
    console_puts(" vm_base=");
    vocabulary_debug_print_hex(base);
    console_puts(" context_vocab=");
    vocabulary_debug_print_hex((uint64_t)(uintptr_t)vm->vocab.context_vocab);
    console_println("");

    /* Truncation check */
    if (cv > 0xFFFFFFFF && (cv >> 32) == 0) {
         console_puts("PANIC: context pointer truncated: ");
         vocabulary_debug_print_hex(cv);
         console_println("");
         sk_hal_panic("context pointer truncated");
    }

    /* Canonical check */
    if (!sf_is_canonical(cv)) {
         console_puts("PANIC: context pointer non-canonical: ");
         vocabulary_debug_print_hex(cv);
         console_println("");
         sk_hal_panic("context pointer non-canonical");
    }

    /* NOTE: DictEntry* (vocabulary pointers) live in the kernel heap, not the
     * VM arena.  An arena-range check here is always wrong — omitted. */
#endif
    vm_store_cell(vm, vm->vocab.context_var_addr, (cell_t)(uintptr_t)vm->vocab.context_vocab);
    vm_store_cell(vm, vm->vocab.current_var_addr, (cell_t)(uintptr_t)vm->vocab.current_vocab);
}

/**
 * @brief Initialize the FORTH vocabulary system
 * @details Sets up FORTH as root vocabulary and allocates VM cells for CONTEXT/CURRENT.
 *          Per-VM (vm->vocab.initialized): each VM in the fleet seeds its own
 *          vocabulary roots from its own dictionary, rather than every VM after
 *          the first silently sharing whichever VM ran this first.
 * @param vm Pointer to VM instance
 */
static void init_vocabulary_system(VM *vm) {
    if (vm->vocab.initialized) return;

    /* Treat vm->latest as the FORTH vocabulary head */
    vm->vocab.forth_vocab = vm->latest;
    vm->vocab.context_vocab = vm->vocab.forth_vocab;
    vm->vocab.current_vocab = vm->vocab.forth_vocab;

    /* Allocate VM cells for CONTEXT and CURRENT */
    void *p1 = vm_allot(vm, sizeof(cell_t));
    if (!p1) {
        vm->error = 1;
        log_message(LOG_ERROR, "VOCAB: failed CONTEXT cell");
        return;
    }
    vm->vocab.context_var_addr = (vaddr_t)((uint8_t *) p1 - vm->memory);

    void *p2 = vm_allot(vm, sizeof(cell_t));
    if (!p2) {
        vm->error = 1;
        log_message(LOG_ERROR, "VOCAB: failed CURRENT cell");
        return;
    }
    vm->vocab.current_var_addr = (vaddr_t)((uint8_t *) p2 - vm->memory);

    vocab_sync_vm_vars(vm);
    vm->vocab.initialized = 1;
}

/* Finder: search CONTEXT chain first, then FORTH chain; skip hidden/smudged */
/* src/word_source/vocabulary_words.c */
static DictEntry *vocab_find_word(VM *vm, const char *name, size_t len) {
    init_vocabulary_system(vm);
    if (!name || len == 0) return NULL;

    /* rebuild per-vocab indices if heads changed */
    if (vm->vocab.ctx_cached_head != vm->vocab.context_vocab)
        fc_rebuild(vm->vocab.context_vocab, vm->vocab.ctx_fc, vm->vocab.ctx_n, &vm->vocab.ctx_cached_head);
    if (vm->vocab.forth_cached_head != vm->vocab.forth_vocab)
        fc_rebuild(vm->vocab.forth_vocab, vm->vocab.forth_fc, vm->vocab.forth_n, &vm->vocab.forth_cached_head);

    const unsigned char first = (unsigned char) name[0];
    const unsigned char last = (unsigned char) name[len - 1];

    /* search CONTEXT bucket (newest-first) */
    {
        DictEntry **bucket = vm->vocab.ctx_fc[first];
        size_t n = vm->vocab.ctx_n[first];
        if (UNLIKELY(!bucket || n == 0)) goto skip_ctx;
        for (size_t i = n; i-- > 0;) {
            DictEntry *e = bucket[i];
            if (!e) continue;
            if ((size_t) e->name_len != len) continue;
            const char *en = e->name;
            if ((unsigned char) en[len - 1] != last) continue;
#ifdef WORD_HIDDEN
            if (e->flags & WORD_HIDDEN) continue;
#endif
#ifdef WORD_SMUDGED
            if (e->flags & WORD_SMUDGED) continue;
#endif
            if (memcmp(en, name, len) == 0) return e;
        }
    }
    skip_ctx:;

    /* then FORTH bucket (if different) */
    if (vm->vocab.context_vocab != vm->vocab.forth_vocab) {
        DictEntry **bucket = vm->vocab.forth_fc[first];
        size_t n = vm->vocab.forth_n[first];
        if (UNLIKELY(!bucket || n == 0)) goto skip_forth;
        for (size_t i = n; i-- > 0;) {
            DictEntry *e = bucket[i];
            if (!e) continue;
            if ((size_t) e->name_len != len) continue;
            const char *en = e->name;
            if ((unsigned char) en[len - 1] != last) continue;
#ifdef WORD_HIDDEN
            if (e->flags & WORD_HIDDEN) continue;
#endif
#ifdef WORD_SMUDGED
            if (e->flags & WORD_SMUDGED) continue;
#endif
            if (memcmp(en, name, len) == 0) return e;
        }
    }
    skip_forth:;
    return NULL;
}


/* Executing a vocabulary word makes it the CONTEXT (FORTH-79) */
static void vocabulary_select_runtime(VM *vm) {
    init_vocabulary_system(vm);

    /* current_executing_entry is set by the interpreter before calling this func,
     * so it correctly identifies which vocabulary word is executing (VA vs VB vs VC).
     * Fall back to vm->latest only if somehow NULL. */
    DictEntry *selected = vm->current_executing_entry;
    if (!selected) selected = vm->latest;
    vm->vocab.context_vocab = selected;
    vocab_sync_vm_vars(vm);

    log_message(LOG_DEBUG, "Vocabulary selected (CONTEXT updated)");
}

/* ===== Words ===== */

/* VOCABULARY ( -- )  Create a new vocabulary; executing it selects itself as CONTEXT. */
/**
 * @brief VOCABULARY ( -- ) Create a new vocabulary
 * @details Creates a vocabulary that when executed makes itself the CONTEXT
 * @param vm Pointer to VM instance
 */
void vocabulary_word_vocabulary(VM *vm) {
    char name[64];

    if (!vm_parse_word(vm, name, sizeof name)) {
        vm->error = 1;
        log_message(LOG_ERROR, "VOCABULARY: missing name");
        return;
    }

    /* Reject duplicate by scanning the ENTIRE dictionary from vm->latest. */
    {
        size_t nlen = strlen(name);
        for (DictEntry *e = vm->latest; e; e = e->link) {
            if (e->name_len == (int) nlen && memcmp(e->name, name, nlen) == 0) {
                vm->error = 1;
                log_message(LOG_ERROR, "VOCABULARY: duplicate '%s'", name);
                return;
            }
            if (e->link == vm->latest) break; /* safety if dictionary ever becomes circular */
        }
    }

    /* Create header that, when executed, selects this vocabulary as CONTEXT */
    DictEntry *entry = vm_create_word(vm, name, (int) strlen(name), vocabulary_select_runtime);
    if (!entry) {
        vm->error = 1;
        return;
    }

    /* Reveal immediately so it’s discoverable by FIND/INTERPRET */
#ifdef WORD_SMUDGED
    entry->flags &= ~WORD_SMUDGED;
#endif
#ifdef WORD_HIDDEN
    entry->flags &= ~WORD_HIDDEN;
#endif

    /* Give the vocabulary a body cell (anchor); surfaces OOM deterministically */
    void *body = vm_allot(vm, sizeof(cell_t));
    if (!body) {
        vm->error = 1;
        log_message(LOG_ERROR, "VOCABULARY: out of dictionary space");
        return;
    }
    vaddr_t body_addr = (vaddr_t)((uint8_t *) body - vm->memory);
    vm_store_cell(vm, body_addr, 0);

    vocab_sync_vm_vars(vm);
    log_message(LOG_DEBUG, "VOCABULARY: created '%s'", name);
}

void vocabulary_create_vocabulary_direct(VM *vm, const char *name)
{
    if (!vm || !name) {
        return;
    }
#if defined(__STARKERNEL__) && SK_PARITY_DEBUG
    console_puts("[VOC_DEBUG] create_vocabulary_direct entry: '");
    console_puts(name);
    console_puts("' HERE=");
    vocabulary_debug_print_hex((uint64_t)vm->here);
    console_puts(" sizeof(cell)=");
    vocabulary_debug_print_hex(sizeof(cell_t));
    console_println("");
#endif
    char local[64];
    size_t len = vocab_safe_len(name, sizeof local - 1);
    if (len == 0) {
        vm->error = 1;
        log_message(LOG_ERROR, "VOCABULARY: missing name");
        return;
    }
    memcpy(local, name, len);
    local[len] = '\0';

    size_t nlen = len;
    for (DictEntry *e = vm->latest; e; e = e->link) {
        if (e->name_len == (int)nlen && memcmp(e->name, local, nlen) == 0) {
            vm->error = 1;
            log_message(LOG_ERROR, "VOCABULARY: duplicate '%s'", local);
            return;
        }
        if (e->link == vm->latest) break;
    }

#if defined(__STARKERNEL__) && SK_PARITY_DEBUG
    console_println("[VOC_DEBUG] before vm_create_word");
#endif
    DictEntry *entry = vm_create_word(vm, local, (int)nlen, vocabulary_select_runtime);
    if (!entry) {
        vm->error = 1;
        return;
    }
#if defined(__STARKERNEL__) && SK_PARITY_DEBUG
    console_println("[VOC_DEBUG] after vm_create_word");
#endif

#ifdef WORD_SMUDGED
    entry->flags &= ~WORD_SMUDGED;
#endif
#ifdef WORD_HIDDEN
    entry->flags &= ~WORD_HIDDEN;
#endif

    void *body = vm_allot(vm, sizeof(cell_t));
    if (!body) {
        vm->error = 1;
        log_message(LOG_ERROR, "VOCABULARY: out of dictionary space");
        return;
    }
#if defined(__STARKERNEL__) && SK_PARITY_DEBUG
    console_println("[VOC_DEBUG] vm_allot succeeded");
#endif
    vaddr_t body_addr = (vaddr_t)((uint8_t *) body - vm->memory);
    vm_store_cell(vm, body_addr, 0);

    vocab_sync_vm_vars(vm);
#if defined(__STARKERNEL__) && SK_PARITY_DEBUG
    console_puts("[VOC_DEBUG] create_vocabulary_direct exit: '");
    console_puts(local);
    console_println("'");
#endif
    log_message(LOG_DEBUG, "VOCABULARY: created '%s'", local);
}

/* DEFINITIONS ( -- )  CURRENT := CONTEXT */
/**
 * @brief DEFINITIONS ( -- ) Set CURRENT to CONTEXT
 * @details Makes new words be defined in the CONTEXT vocabulary
 * @param vm Pointer to VM instance
 */
void vocabulary_word_definitions(VM *vm) {
    init_vocabulary_system(vm);
    vm->vocab.current_vocab = vm->vocab.context_vocab;
    vocab_sync_vm_vars(vm);
    log_message(LOG_DEBUG, "DEFINITIONS: CURRENT := CONTEXT");
}

/* CONTEXT ( -- addr )  Return VM address of CONTEXT cell */
/**
 * @brief CONTEXT ( -- addr ) Get CONTEXT variable address
 * @details Returns VM address of cell containing CONTEXT vocabulary pointer
 * @param vm Pointer to VM instance
 */
void vocabulary_word_context(VM *vm) {
    init_vocabulary_system(vm);
    vm_push(vm, CELL(vm->vocab.context_var_addr));
}

/* CURRENT ( -- addr )  Return VM address of CURRENT cell */
/**
 * @brief CURRENT ( -- addr ) Get CURRENT variable address
 * @details Returns VM address of cell containing CURRENT vocabulary pointer
 * @param vm Pointer to VM instance
 */
void vocabulary_word_current(VM *vm) {
    init_vocabulary_system(vm);
    vm_push(vm, CELL(vm->vocab.current_var_addr));
}

/* FORTH ( -- )  Make FORTH the CONTEXT vocabulary (and nothing else) */
/**
 * @brief FORTH ( -- ) Select FORTH vocabulary
 * @details Makes FORTH the CONTEXT vocabulary
 * @param vm Pointer to VM instance
 */
void vocabulary_word_forth(VM *vm) {
    init_vocabulary_system(vm);
    vm->vocab.context_vocab = vm->vocab.forth_vocab;
    vocab_sync_vm_vars(vm);
    log_message(LOG_DEBUG, "FORTH selected (CONTEXT := FORTH)");
}

/* (FIND) ( addr -- addr flag )  primitive finder on counted string at addr */
/**
 * @brief (FIND) ( addr -- addr flag ) Find word in dictionary
 * @details Searches for counted string at addr in CONTEXT then FORTH vocabularies
 * @param vm Pointer to VM instance
 */
void vocabulary_word_paren_find(VM *vm) {
    if (vm->dsp < 0) {
        vm->error = 1;
        return;
    }

    cell_t addr = vm->data_stack[vm->dsp]; /* keep addr */
    vaddr_t a = VM_ADDR(addr);
    if (!vm_addr_ok(vm, a, 1)) {
        vm_push(vm, 0);
        return;
    }

    uint8_t *s = vm_ptr(vm, a);
    if (!s) {
        vm_push(vm, 0);
        return;
    }

    uint8_t n = s[0];
    if (!vm_addr_ok(vm, a + 1, n)) {
        vm_push(vm, 0);
        return;
    }
    const char *name = (const char *) &s[1];

    DictEntry *e = vocab_find_word(vm, name, (size_t) n);
    if (e) {
        vm->data_stack[vm->dsp] = (cell_t)(uintptr_t)
        e;
        vm_push(vm, (e->flags & WORD_IMMEDIATE) ? 1 : -1);
    } else {
        vm_push(vm, 0);
    }
}

/* ORDER ( -- )  Display search order (CONTEXT then FORTH) and CURRENT */
/**
 * @brief ORDER ( -- ) Display search order
 * @details Shows CONTEXT and FORTH vocabularies plus CURRENT
 * @param vm Pointer to VM instance
 */
void vocabulary_word_order(VM *vm) {
    init_vocabulary_system(vm);

    DictEntry *context_vocab = vm->vocab.context_vocab;
    DictEntry *forth_vocab = vm->vocab.forth_vocab;
    DictEntry *current_vocab = vm->vocab.current_vocab;

    printf("Search order: ");
    if (context_vocab && context_vocab->name_len > 0) {
        fwrite(context_vocab->name, 1, (size_t) context_vocab->name_len, stdout);
        if (context_vocab != forth_vocab) printf(" ");
    }
    if (context_vocab != forth_vocab && forth_vocab && forth_vocab->name_len > 0) {
        fwrite(forth_vocab->name, 1, (size_t) forth_vocab->name_len, stdout);
    }
    if (!context_vocab && forth_vocab && forth_vocab->name_len > 0) {
        fwrite(forth_vocab->name, 1, (size_t) forth_vocab->name_len, stdout);
    }
    printf("\n");

    printf("Current: ");
    if (current_vocab && current_vocab->name_len > 0) {
        fwrite(current_vocab->name, 1, (size_t) current_vocab->name_len, stdout);
    } else {
        printf("(none)");
    }
    printf("\n");
}

/* Vocabulary-aware lookup for the interpreter */
/**
 * @brief Find word in vocabulary-aware dictionary
 * @details Searches CONTEXT then FORTH vocabularies
 * @param vm Pointer to VM instance
 * @param name Word name to find
 * @param len Length of word name
 * @return Pointer to dictionary entry if found, NULL if not found
 */
DictEntry *vm_vocabulary_find_word(VM *vm, const char *name, size_t len) {
    return vocab_find_word(vm, name, len);
}

/**
 * @brief Register all FORTH-79 vocabulary words
 * @details Registers VOCABULARY, DEFINITIONS, CONTEXT, CURRENT, FORTH, ORDER, and (FIND)
 * @param vm Pointer to VM instance
 */
void register_vocabulary_words(VM *vm) {
    register_word(vm, "VOCABULARY", vocabulary_word_vocabulary);
    register_word(vm, "DEFINITIONS", vocabulary_word_definitions);
    register_word(vm, "CONTEXT", vocabulary_word_context);
    register_word(vm, "CURRENT", vocabulary_word_current);
    register_word(vm, "FORTH", vocabulary_word_forth);
    register_word(vm, "ORDER", vocabulary_word_order);
    register_word(vm, "(FIND)", vocabulary_word_paren_find);
    init_vocabulary_system(vm);
}