LithosAnanke/src/word_source/log_words.c

/*
  StarForth — Steady-State Virtual Machine Runtime

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

  Licensed under the StarForth License, Version 1.0
*/

/* log_words.c — FORTH words for log level control and string emission */

#include "include/log_words.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
#include <stdint.h>

#ifdef __STARKERNEL__
#include "starkernel/log_region.h"
#include "starkernel/log_attrib.h"     /* vm_log_attributed_vm() */
#include "starkernel/capsule_birth.h"  /* capsule_vm_registry_get, VMRegistryEntry */
#include "starkernel/console.h"        /* console_println() -- (LOG-APPEND-RAW) diagnostics */
#include <string.h>                    /* strlen */
#endif

/* ── Level constants ─────────────────────────────────────────────────── */

/** @brief LOG-ERROR ( -- n )  Push the @c LOG_ERROR level constant. */
static void log_word_error(VM *vm) { vm_push(vm, (cell_t)LOG_ERROR); }
/** @brief LOG-WARN  ( -- n )  Push the @c LOG_WARN level constant. */
static void log_word_warn (VM *vm) { vm_push(vm, (cell_t)LOG_WARN);  }
/** @brief LOG-INFO  ( -- n )  Push the @c LOG_INFO level constant. */
static void log_word_info (VM *vm) { vm_push(vm, (cell_t)LOG_INFO);  }
/** @brief LOG-TEST  ( -- n )  Push the @c LOG_TEST level constant. */
static void log_word_test (VM *vm) { vm_push(vm, (cell_t)LOG_TEST);  }
/** @brief LOG-DEBUG ( -- n )  Push the @c LOG_DEBUG level constant. */
static void log_word_debug(VM *vm) { vm_push(vm, (cell_t)LOG_DEBUG); }

/* ── LOG-LEVEL! ( n -- ) ─────────────────────────────────────────────── */

/**
 * @brief LOG-LEVEL! ( n -- )
 *
 * Pops @c n from the stack and calls @c log_set_level() to update the active
 * log filter. Values below @c LOG_ERROR are clamped to @c LOG_ERROR; values
 * above @c LOG_DEBUG are clamped to @c LOG_DEBUG.
 */
static void log_word_set_level(VM *vm)
{
    if (vm->dsp < 0) {
        log_message(LOG_ERROR, "LOG-LEVEL!: stack underflow");
        vm->error = 1;
        return;
    }
    cell_t n = vm_pop(vm);
    if (n < (cell_t)LOG_ERROR) n = (cell_t)LOG_ERROR;
    if (n > (cell_t)LOG_DEBUG) n = (cell_t)LOG_DEBUG;
    log_set_level((LogLevel)n);
}

/* ── LOG-LEVEL@ ( -- n ) ─────────────────────────────────────────────── */

/**
 * @brief LOG-LEVEL@ ( -- n )
 *
 * Pushes the current log level onto the stack.
 */
static void log_word_get_level(VM *vm)
{
    vm_push(vm, (cell_t)log_get_level());
}

/* ── (do-log-*) runtime words ────────────────────────────────────────── */
/*
 * Called at runtime when a compiled LOG-INFO" etc. executes.
 * Reads the inline counted string from the threaded-code stream (same
 * layout as (do-string)) and routes it through log_message().
 *
 * Inline layout: [1 length byte][n string bytes][padding to cell boundary]
 */

static void log_do_emit(VM *vm, LogLevel level)
{
    if (vm->rsp < 0) {
        log_message(LOG_ERROR, "(do-log-*): return-stack underflow");
        vm->error = 1;
        return;
    }
    uint8_t *data = (uint8_t *)(uintptr_t)vm->return_stack[vm->rsp];
    if (!data) {
        log_message(LOG_ERROR, "(do-log-*): NULL inline-string pointer");
        vm->error = 1;
        return;
    }
    uint8_t n = data[0];
    /* advance IP before emitting so re-entrant calls see correct state */
    size_t skip   = 1 + (size_t)n;
    size_t padded = (skip + (sizeof(cell_t) - 1)) & ~(sizeof(cell_t) - 1);
    vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)(data + padded);
    log_message(level, "%.*s", (int)n, (const char *)(data + 1));
}

static void log_do_error(VM *vm) { log_do_emit(vm, LOG_ERROR); }
static void log_do_warn (VM *vm) { log_do_emit(vm, LOG_WARN);  }
static void log_do_info (VM *vm) { log_do_emit(vm, LOG_INFO);  }
static void log_do_test (VM *vm) { log_do_emit(vm, LOG_TEST);  }
static void log_do_debug(VM *vm) { log_do_emit(vm, LOG_DEBUG); }

/* ── Shared parse/compile helper ─────────────────────────────────────── */
/*
 * Parses a string literal "ccc" from the input stream (skipping an optional
 * leading space, consuming up to the closing double-quote).  In interpret
 * mode emits directly via log_message().  In compile mode emits the named
 * runtime word followed by the inline counted string block.
 */
static void log_emit_string(VM *vm, LogLevel level,
                             const char *rt_name, int rt_nlen)
{
    const char *src = vm->input_buffer;
    size_t pos = vm->input_pos;
    size_t end = vm->input_length;

    if (!src || pos > end) {
        log_message(LOG_ERROR, "LOG-*\": no input buffer");
        vm->error = 1;
        return;
    }
    if (pos < end && src[pos] == ' ') pos++;

    size_t start = pos;
    while (pos < end && src[pos] != '"') pos++;
    if (pos >= end) {
        log_message(LOG_ERROR, "LOG-*\": unterminated string literal");
        vm->error = 1;
        return;
    }

    size_t n = pos - start;
    if (n > 255) n = 255;
    vm->input_pos = pos + 1;

    if (vm->mode == MODE_INTERPRET) {
        log_message(level, "%.*s", (int)n, src + start);
        return;
    }

    /* Compilation: emit runtime word then inline [len][chars][pad] */
    DictEntry *rt = vm_find_word(vm, rt_name, (size_t)rt_nlen);
    if (!rt) {
        log_message(LOG_ERROR, "LOG-*\": runtime word '%.*s' not found", rt_nlen, rt_name);
        vm->error = 1;
        return;
    }
    vm_compile_word(vm, rt);

    size_t skip   = 1 + n;
    size_t padded = (skip + (sizeof(cell_t) - 1)) & ~(sizeof(cell_t) - 1);
    uint8_t *raw  = (uint8_t *)vm_allot(vm, padded);
    if (!raw) {
        log_message(LOG_ERROR, "LOG-*\": vm_allot failed");
        vm->error = 1;
        return;
    }
    raw[0] = (uint8_t)n;
    for (size_t i = 0; i < n; i++) raw[1 + i] = (uint8_t)src[start + i];
    for (size_t i = 1 + n; i < padded; i++) raw[i] = 0;
}

/* ── LOG-ERROR" LOG-WARN" LOG-INFO" LOG-TEST" LOG-DEBUG" (IMMEDIATE) ── */

/** @brief LOG-ERROR" ( "ccc<quote>" -- ) Log string at ERROR level. IMMEDIATE. */
static void log_word_error_quote(VM *vm) {
    log_emit_string(vm, LOG_ERROR, "(do-log-error)", 14);
}
/** @brief LOG-WARN" ( "ccc<quote>" -- ) Log string at WARN level. IMMEDIATE. */
static void log_word_warn_quote(VM *vm) {
    log_emit_string(vm, LOG_WARN,  "(do-log-warn)",  13);
}
/** @brief LOG-INFO" ( "ccc<quote>" -- ) Log string at INFO level. IMMEDIATE. */
static void log_word_info_quote(VM *vm) {
    log_emit_string(vm, LOG_INFO,  "(do-log-info)",  13);
}
/** @brief LOG-TEST" ( "ccc<quote>" -- ) Log string at TEST level. IMMEDIATE. */
static void log_word_test_quote(VM *vm) {
    log_emit_string(vm, LOG_TEST,  "(do-log-test)",  13);
}
/** @brief LOG-DEBUG" ( "ccc<quote>" -- ) Log string at DEBUG level. IMMEDIATE. */
static void log_word_debug_quote(VM *vm) {
    log_emit_string(vm, LOG_DEBUG, "(do-log-debug)", 14);
}

/* ── LOG-*-STR ( c-addr u -- ) ──────────────────────────────────────── */
/*
 * Stack-consuming variants: take a counted string from the stack (as
 * produced by S") and route it through log_message() at the named level.
 * addr is a VM byte offset into vm->memory, identical to how TYPE works.
 */
static void log_str_emit(VM *vm, LogLevel level)
{
    if (vm->dsp < 1) {
        log_message(LOG_ERROR, "LOG-*-STR: stack underflow");
        vm->error = 1;
        return;
    }
    cell_t u    = vm_pop(vm);
    cell_t addr = vm_pop(vm);
    if (u <= 0) return;
    if (addr < 0 || (addr + u) > (cell_t)VM_MEMORY_SIZE) {
        log_message(LOG_ERROR, "LOG-*-STR: address out of range");
        vm->error = 1;
        return;
    }
    if (u > LOG_LINE_MAX - 1) u = LOG_LINE_MAX - 1;
    log_message(level, "%.*s", (int)u, (const char *)&vm->memory[addr]);
}

/** @brief LOG-ERROR-STR ( c-addr u -- ) Log string from stack at ERROR level. */
static void log_word_error_str(VM *vm) { log_str_emit(vm, LOG_ERROR); }
/** @brief LOG-WARN-STR  ( c-addr u -- ) Log string from stack at WARN level. */
static void log_word_warn_str (VM *vm) { log_str_emit(vm, LOG_WARN);  }
/** @brief LOG-INFO-STR  ( c-addr u -- ) Log string from stack at INFO level. */
static void log_word_info_str (VM *vm) { log_str_emit(vm, LOG_INFO);  }
/** @brief LOG-TEST-STR  ( c-addr u -- ) Log string from stack at TEST level. */
static void log_word_test_str (VM *vm) { log_str_emit(vm, LOG_TEST);  }
/** @brief LOG-DEBUG-STR ( c-addr u -- ) Log string from stack at DEBUG level. */
static void log_word_debug_str(VM *vm) { log_str_emit(vm, LOG_DEBUG); }

/* ── (LOG-APPEND-RAW) ( level timestamp msg-addr msg-u -- ) ── */
/*
 * Kernel-only. Writes one record directly to Artemis's on-disk log ring
 * (log_region.c) -- the primitive LOG-APPEND (capsules/artemis/init.4th)
 * wraps this with the FORTH-level word name callers actually use.
 * Deliberately does NOT call log_message() anywhere in this path (see
 * log_region.c's own doc comment on why) -- errors are reported back via
 * vm->error, never logged.
 *
 * Source is NOT a caller-supplied parameter -- an earlier revision took
 * source-addr/source-u off the stack, which let any caller claim to be
 * any source. It is derived from vm_log_attributed_vm() (log_attrib.h)
 * instead: the real VM currently executing, looked up by name via the
 * VM registry, or the fixed "HADES" pseudo-source when no VM is attributed
 * (matching log_attrib.h's own documented convention).
 */
#ifdef __STARKERNEL__
static void log_word_append_raw(VM *vm)
{
    /* Diagnostics here go via console_println(), not log_message() -- this
     * function's own doc comment above forbids log_message() (recursion
     * into the log ring it writes to); console_println() carries no such
     * risk and covers the "by hand at the console for a smoke test" case
     * that same comment names (FABRIC-3.md §XXXII.6). */
    if (vm->dsp < 3) {
        console_println("(LOG-APPEND-RAW): stack underflow");
        vm->error = 1;
        return;
    }
    cell_t msg_u     = vm_pop(vm);
    cell_t msg_addr  = vm_pop(vm);
    cell_t timestamp = vm_pop(vm);
    cell_t level     = vm_pop(vm);

    if (msg_u < 0) {
        console_println("(LOG-APPEND-RAW): negative message length");
        vm->error = 1;
        return;
    }
    if (msg_addr < 0 || (msg_addr + msg_u) > (cell_t)VM_MEMORY_SIZE) {
        console_println("(LOG-APPEND-RAW): message address out of range");
        vm->error = 1;
        return;
    }

    const char *msg = (const char *)&vm->memory[msg_addr];

    char source[VM_NAME_MAX];
    VM *attrib = vm_log_attributed_vm();
    VMRegistryEntry entry;
    if (attrib && capsule_vm_registry_get(attrib->stadium_vm_id, &entry) == 0) {
        size_t i = 0;
        for (; i < sizeof(source) - 1 && entry.name[i]; i++) source[i] = entry.name[i];
        source[i] = '\0';
    } else {
        const char *hades = "HADES";
        size_t i = 0;
        for (; i < sizeof(source) - 1 && hades[i]; i++) source[i] = hades[i];
        source[i] = '\0';
    }

    /* log_region_append()'s return is three-valued (see log_region.h):
     * 0 success, 1 dropped by design (protected a higher-priority record,
     * not a fault -- no vm->error), -1 a genuine write failure. */
    if (log_region_append((uint8_t)level, (uint64_t)timestamp,
                           source, (uint32_t)strlen(source),
                           msg, (uint32_t)msg_u) < 0) {
        vm->error = 1;
    }
}
#endif

/* ── Registration ────────────────────────────────────────────────────── */

/**
 * @brief Register all log words with the VM dictionary.
 *
 * Level constants:  LOG-ERROR  LOG-WARN  LOG-INFO  LOG-TEST  LOG-DEBUG
 * Level control:    LOG-LEVEL!  LOG-LEVEL@
 * Runtime (hidden): (do-log-error)  (do-log-warn)  (do-log-info)
 *                   (do-log-test)   (do-log-debug)
 * String literals:  LOG-ERROR"  LOG-WARN"  LOG-INFO"  LOG-TEST"  LOG-DEBUG"
 * Stack string:     LOG-ERROR-STR  LOG-WARN-STR  LOG-INFO-STR
 *                   LOG-TEST-STR   LOG-DEBUG-STR
 */
void register_log_words(VM *vm)
{
    /* Level constants (unchanged) */
    register_word(vm, "LOG-ERROR", log_word_error);
    register_word(vm, "LOG-WARN",  log_word_warn);
    register_word(vm, "LOG-INFO",  log_word_info);
    register_word(vm, "LOG-TEST",  log_word_test);
    register_word(vm, "LOG-DEBUG", log_word_debug);
    register_word(vm, "LOG-LEVEL!", log_word_set_level);
    register_word(vm, "LOG-LEVEL@", log_word_get_level);

    /* Runtime words for compiled LOG-*" — registered before the immediates
     * that reference them so vm_find_word() can locate them at compile time */
    register_word(vm, "(do-log-error)", log_do_error);
    register_word(vm, "(do-log-warn)",  log_do_warn);
    register_word(vm, "(do-log-info)",  log_do_info);
    register_word(vm, "(do-log-test)",  log_do_test);
    register_word(vm, "(do-log-debug)", log_do_debug);

    /* String-literal LOG-*" words — IMMEDIATE */
    register_word(vm, "LOG-ERROR\"", log_word_error_quote); vm_make_immediate(vm);
    register_word(vm, "LOG-WARN\"",  log_word_warn_quote);  vm_make_immediate(vm);
    register_word(vm, "LOG-INFO\"",  log_word_info_quote);  vm_make_immediate(vm);
    register_word(vm, "LOG-TEST\"",  log_word_test_quote);  vm_make_immediate(vm);
    register_word(vm, "LOG-DEBUG\"", log_word_debug_quote); vm_make_immediate(vm);

    /* Stack-consuming LOG-*-STR words */
    register_word(vm, "LOG-ERROR-STR", log_word_error_str);
    register_word(vm, "LOG-WARN-STR",  log_word_warn_str);
    register_word(vm, "LOG-INFO-STR",  log_word_info_str);
    register_word(vm, "LOG-TEST-STR",  log_word_test_str);
    register_word(vm, "LOG-DEBUG-STR", log_word_debug_str);

#ifdef __STARKERNEL__
    register_word(vm, "(LOG-APPEND-RAW)", log_word_append_raw);
#endif
}