admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Reorganize source tree: kernel/, v3/, v4/ split and board infrastructure

Browse Source 
Source tree reorganization:
- Move StarForth v3 engine to v3/ (src/, include/, Makefile)
- Move kernel to kernel/ (src/, include/, linker/, Makefile)
- Create v4/ skeleton for F18-ISA golden model (DECOMPOSITION.md, JUSTIFICATION.md)
- Move FABRIC-0..4.md to docs/fabric/
- Move ONTOLOGY.md and ROADMAP.md to docs/

Board infrastructure:
- Add boards/ser5/, boards/raspi/, boards/milkv/, boards/zynq7020/
- Each board has board.mk (ISA, CPU flags, boot recipe) and README.md
- Root Makefile becomes thin dispatcher: boot_image, all, clean, docs take TARGET
- make boot_image TARGET=SER5|RASPI|MILKV builds one GPT/MBR image per board
- ZYNQ7020 target exists but stops with clear error (ARMv7 port not built yet)
- scripts/mkdiskimage.sh builds disk images for all boards

Docs pipeline:
- docs/book/ with LaTeX master (main.tex) and Makefile
- pandoc converts Markdown to LaTeX at build time
- Two Lua filters: table-widths.lua (wide tables wrap), code-breaks.lua (inline code breaks)
- make docs builds single PDF (754 pages, 0 missing characters)
- make docs TARGET=<board> adds board appendix
- build/docs/<book|board>/meta.tex stamps git commit into PDF

Bug fixes:
- 42 include paths that only worked by accident now use correct relative paths
- clang-18 hardcode replaced with configurable CC variable (fixed aarch64 build)
- Pi 5: kernel_2712.img linked at 0x80000, .bss zeroed, memory reserved
- Doxyfile, .clang-tidy, README.md, Kconfig paths updated

Verified:
- Hosted v3 build passes 1012 tests, 0 failures
- SER5 image boots in QEMU (OVMF), POST passes, K exact (65536 = Q48_ONE)
- Milk-V image boots in QEMU (OpenSBI + U-Boot + bootefi), POST passes
- make clean TARGET=<board> removes only that board and its ISA objects
- make all builds all boards, hosted v3, and docs in one run

Co-authored-by: Junie <junie@jetbrains.com>
This commit is contained in:
rajames
2026-10-01 15:40:09 -04:00
co-authored by Junie
parent 3c709c115b
commit a8b70e88d3
630 changed files with 2646 additions and 2036 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v3/src/README.md
+58
View File
@@ -0,0 +1,58 @@
# src/
Hosted StarForth VM implementation (compiled by the root `Makefile`).
Bare-metal kernel sources live in `src/starkernel/`; FORTH word
implementations in `src/word_source/`; the test harness in
`src/test_runner/`; platform shims in `src/platform/`.
**Entry point / interpreter core**
- `main.c` — CLI entry point, VM init, DoE mode dispatch.
- `vm.c` — interpreter loop, stacks, dictionary state (the central
runtime file).
- `vm_api.c` — external VM API implementation.
- `vm_bootstrap.c` — VM bootstrap initialization.
- `vm_debug.c` — debugging utilities.
- `vm_time.c` — time-related VM operations.
- `vm_internal.h` — internal-only declarations shared across the `vm_*.c`
files, not part of the public `include/vm_api.h` surface.
- `repl.c` — REPL read-eval-print loop.
- `cli.c` — CLI argument parsing.
- `io.c` — I/O operations.
- `log.c` — logging infrastructure.
**Memory / dictionary / blocks**
- `memory_management.c` — dictionary allocator.
- `dictionary_management.c` — dictionary allocation and search.
- `dictionary_heat_optimization.c` — Loop #1 execution-heat tracking.
- `word_registry.c` — word registration system.
- `block_subsystem.c` — logical→physical block mapper.
- `blkio_file.c`, `blkio_ram.c`, `blkio_factory.c` — block I/O backends
(file-backed, RAM-backed) and the factory that selects between them.
- `stack_management.c` — stack operations.
**Physics-driven adaptive runtime (7 feedback loops)**
- `physics_runtime.c` — main physics coordinator.
- `physics_hotwords_cache.c` — Loop #1 hot-words caching.
- `physics_metadata.c` — per-word metadata tracking.
- `physics_pipelining_metrics.c` — Loop #4 word-transition prediction.
- `physics_execution_hooks.c` — execution instrumentation.
- `rolling_window_of_truth.c` — Loop #2 circular execution-history buffer.
- `inference_engine.c` — Loops #5/#6, statistical inference (window-width,
decay-slope).
- `ssm_jacquard.c` — L8 Jacquard steady-state mode selector; consumes
`compudynamics.c` for tuning-word/config lookups.
- `compudynamics.c` — generic compudynamics module (`cd_tuning_word()`,
`cd_tuning_vm()`); the score/UCB/reward/weight constants for the L8
adaptive table live here, not in `ssm_jacquard.c`.
- `heartbeat_export.c` — heartbeat metrics export (CSV export function
itself not yet implemented — see `docs/working/architecture/heartbeat_csv_export.md`).
**Math / measurement**
- `math_portable.c` — portable math functions.
- `profiler.c` — performance profiling.
- `doe_metrics.c` — Design of Experiments metrics (2^7 factorial).
Any `.bak` file alongside a `.c` file here (`doe_metrics.c.bak`,
`inference_engine.c.bak`, `vm.c.bak`) is a pre-edit backup left by a past
maintenance script (see `scripts/remove_loop_conditionals.sh`), not a
build input.
v3/src/blkio_factory.c
+170
View File
@@ -0,0 +1,170 @@
/*
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.
*/
// -----------------------------------------------------------------------------
// StarForth - Block I/O Factory (Implementation)
// -----------------------------------------------------------------------------
#include <stdint.h>
#include <stddef.h>
#include <string.h>
#include "blkio.h"
#include "blkio_factory.h"
/* Backends */
extern size_t blkio_file_state_size(void);
extern const blkio_vtable_t *blkio_file_vtable(void);
extern int blkio_file_init_state(void *state_mem, size_t state_len,
const char *path,
uint32_t total_blocks,
uint32_t fbs,
uint8_t read_only,
uint8_t create_if_missing,
uint8_t truncate_to_size,
void **out_opaque);
extern size_t blkio_ram_state_size(void);
extern const blkio_vtable_t *blkio_ram_vtable(void);
extern int blkio_ram_init_state(void *state_mem, size_t state_len,
uint8_t *base, uint32_t total_blocks,
uint32_t fbs, uint8_t read_only,
void **out_opaque);
/** @brief Return 1 if string @c s is non-NULL and non-empty. */
static int nonempty(const char *s) { return (s && *s); }
/**
* @brief Open a block I/O device using the best available backend.
*
* Selects the file backend when @c disk_img_path is non-empty, otherwise
* falls back to the RAM backend using @c ram_base / @c ram_blocks.
*
* File backend behaviour:
* - Creates the file if it does not exist (unless @c read_only is set).
* - Derives @c total_blocks from the file size when @c total_blocks == 0.
* - Sets @c *out_used_file = 1 on success.
*
* RAM backend behaviour:
* - @c ram_base must point to at least @c ram_blocks * @c fbs bytes of
* caller-owned memory that outlives the device.
*
* @param dev Output device handle to populate
* @param disk_img_path Path to disk image file, or NULL/empty for RAM
* @param read_only 1 = open read-only, 0 = read-write
* @param total_blocks Desired block count (0 = derive from file size)
* @param fbs FORTH block size in bytes (0 = use @c BLKIO_FORTH_BLOCK_SIZE)
* @param state_mem Caller-allocated state buffer (must be large enough)
* @param state_len Size of @c state_mem in bytes
* @param ram_base Base of RAM block array (used only when no disk path)
* @param ram_blocks Number of blocks in @c ram_base
* @param out_used_file Optional output: set to 1 if the file backend was used
* @return @c BLKIO_OK on success, or a @c BLKIO_E* error code
*/
int blkio_factory_open(blkio_dev_t *dev,
const char *disk_img_path,
uint8_t read_only,
uint32_t total_blocks,
uint32_t fbs,
void *state_mem,
size_t state_len,
uint8_t *ram_base,
uint32_t ram_blocks,
uint8_t *out_used_file) {
if (out_used_file) *out_used_file = 0;
if (!dev || !state_mem || state_len == 0) return BLKIO_EINVAL;
const uint32_t efbs = (fbs ? fbs : BLKIO_FORTH_BLOCK_SIZE);
if (nonempty(disk_img_path)) {
const size_t need = blkio_file_state_size();
if (state_len < need) return BLKIO_ENOSPACE;
void *opaque = NULL;
const uint8_t create_if_missing = read_only ? 0u : 1u;
const uint8_t truncate_to_size = (!read_only && total_blocks > 0) ? 1u : 0u;
int rc = blkio_file_init_state(state_mem, state_len,
disk_img_path,
total_blocks,
efbs,
read_only,
create_if_missing,
truncate_to_size,
&opaque);
if (rc != BLKIO_OK) return rc;
blkio_params_t p = {
.forth_block_size = efbs,
.total_blocks = total_blocks, /* 0 => derive in file_open */
.opaque = opaque
};
rc = blkio_open(dev, blkio_file_vtable(), &p);
if (rc == BLKIO_OK && out_used_file) *out_used_file = 1u;
return rc;
}
if (!ram_base || ram_blocks == 0) return BLKIO_EINVAL;
const size_t need_ram = blkio_ram_state_size();
if (state_len < need_ram) return BLKIO_ENOSPACE;
void *opaque = NULL;
int rc = blkio_ram_init_state(state_mem, state_len,
ram_base, ram_blocks,
efbs, read_only,
&opaque);
if (rc != BLKIO_OK) return rc;
const blkio_params_t p = {
.forth_block_size = efbs,
.total_blocks = ram_blocks,
.opaque = opaque
};
return blkio_open(dev, blkio_ram_vtable(), &p);
}
v3/src/blkio_file.c
+400
View File
@@ -0,0 +1,400 @@
/*
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.
*/
// -----------------------------------------------------------------------------
// StarForth - File-backed Block I/O backend (portable)
// - Uses lseek()+read()/write() shims (no pread/pwrite requirement).
// - Deterministic full-block I/O; rejects short I/O.
// - Single-process/serialized access expected for correctness.
// -----------------------------------------------------------------------------
#include "blkio.h"
#include <unistd.h> // read, write, lseek, close
#include <fcntl.h> // open flags
#include <sys/stat.h> // fstat
#include <sys/types.h> // off_t
#include <errno.h>
#include <string.h> // memset
#include <stdint.h>
#ifndef PATH_MAX
#define PATH_MAX 4096
#endif
typedef struct {
int fd;
char path[PATH_MAX];
uint32_t total_blocks;
uint32_t fbs;
uint8_t read_only;
} blkio_file_state_t;
/**
* @brief Return the byte size required for a @c blkio_file_state_t.
*
* Used by @c blkio_factory_open() to verify the caller's state buffer is
* large enough before calling @c blkio_file_init_state().
*
* @return sizeof(blkio_file_state_t)
*/
size_t blkio_file_state_size(void) { return sizeof(blkio_file_state_t); }
/**
* @brief Initialise a @c blkio_file_state_t in caller-provided memory.
*
* Copies the path into state (truncated to PATH_MAX-1), sets @c fbs,
* @c total_blocks, and @c read_only, and writes the state pointer to
* @c *out_opaque. The file descriptor is initialised to -1; the actual
* @c open() call happens in @c file_open() (the vtable open method).
* @c create_if_missing and @c truncate_to_size are accepted for API
* compatibility but currently unused (creation is handled in @c file_open()).
*
* @param state_mem Caller-allocated state buffer
* @param state_len Size of @c state_mem (must be >= blkio_file_state_size())
* @param path Path to the disk image file
* @param total_blocks Total block count (0 = derive from file size at open)
* @param fbs FORTH block size in bytes
* @param read_only 1 = open read-only, 0 = read-write
* @param create_if_missing Ignored (reserved for future use)
* @param truncate_to_size Ignored (reserved for future use)
* @param out_opaque Output: set to @c state_mem on success
* @return @c BLKIO_OK on success, @c BLKIO_EINVAL on bad arguments
*/
int blkio_file_init_state(void *state_mem, size_t state_len,
const char *path,
uint32_t total_blocks,
uint32_t fbs,
uint8_t read_only,
uint8_t create_if_missing,
uint8_t truncate_to_size,
void **out_opaque) {
(void) create_if_missing;
(void) truncate_to_size;
if (!state_mem || state_len < sizeof(blkio_file_state_t) || !path || !out_opaque)
return BLKIO_EINVAL;
blkio_file_state_t *st = (blkio_file_state_t *) state_mem;
memset(st, 0, sizeof(*st));
st->fd = -1;
size_t n = 0;
while (path[n] && n < (PATH_MAX - 1)) {
st->path[n] = path[n];
n++;
}
st->path[n] = '\0';
if (st->path[0] == '\0') return BLKIO_EINVAL;
st->fbs = (fbs ? fbs : BLKIO_FORTH_BLOCK_SIZE);
st->total_blocks = total_blocks; // may be 0 (derive later)
st->read_only = read_only ? 1u : 0u;
*out_opaque = (void *) st;
return BLKIO_OK;
}
/**
* @brief Perform a complete read of @c len bytes at absolute offset @c off_abs.
*
* Uses @c lseek() + @c read() loops to handle short reads and EINTR.
* Not safe for concurrent readers/writers on the same file descriptor.
* Returns -1 on any I/O error or unexpected EOF.
*
* @param fd Open file descriptor
* @param buf Destination buffer (must be >= @c len bytes)
* @param len Number of bytes to read
* @param off_abs Absolute byte offset within the file
* @return 0 on success, -1 on error (errno set)
*/
static int full_read_at(int fd, void *buf, size_t len, off_t off_abs) {
uint8_t *p = (uint8_t *) buf;
size_t done = 0;
while (done < len) {
if (lseek(fd, off_abs + (off_t) done, SEEK_SET) == (off_t) - 1) return -1;
ssize_t r = read(fd, p + done, len - done);
if (r < 0) {
if (errno == EINTR) continue;
return -1;
}
if (r == 0) {
errno = EIO;
return -1;
} /* unexpected EOF */
done += (size_t) r;
}
return 0;
}
/**
* @brief Perform a complete write of @c len bytes at absolute offset @c off_abs.
*
* Uses @c lseek() + @c write() loops to handle short writes and EINTR.
* Not safe for concurrent readers/writers on the same file descriptor.
* Returns -1 on any I/O error.
*
* @param fd Open file descriptor
* @param buf Source buffer (must be >= @c len bytes)
* @param len Number of bytes to write
* @param off_abs Absolute byte offset within the file
* @return 0 on success, -1 on error (errno set)
*/
static int full_write_at(int fd, const void *buf, size_t len, off_t off_abs) {
const uint8_t *p = (const uint8_t *) buf;
size_t done = 0;
while (done < len) {
if (lseek(fd, off_abs + (off_t) done, SEEK_SET) == (off_t) - 1) return -1;
ssize_t w = write(fd, p + done, len - done);
if (w < 0) {
if (errno == EINTR) continue;
return -1;
}
if (w == 0) {
errno = EIO;
return -1;
} /* should not happen */
done += (size_t) w;
}
return 0;
}
/** @brief Open the file and attach it to the device handle. */
static int file_open(blkio_dev_t *dev, const blkio_params_t *p);
/** @brief Close the file descriptor held by the device. */
static int file_close(blkio_dev_t * dev);
/** @brief Read one FORTH block from the file into @c dst. */
static int file_read(blkio_dev_t *dev, uint32_t fblock, void *dst);
/** @brief Write one FORTH block from @c src into the file. */
static int file_write(blkio_dev_t *dev, uint32_t fblock, const void *src);
/** @brief Flush (fsync) pending writes to the file. */
static int file_flush(blkio_dev_t * dev);
/** @brief Return device info (block size, count, physical size, read-only flag). */
static int file_info(blkio_dev_t * dev, blkio_info_t * out);
static const blkio_vtable_t BLKIO_FILE_VT = {
.open = file_open,
.close = file_close,
.read = file_read,
.write = file_write,
.flush = file_flush,
.info = file_info
};
/**
* @brief Return the vtable for the file-backed block I/O backend.
* @return Pointer to the static @c blkio_vtable_t for file devices
*/
const blkio_vtable_t *blkio_file_vtable(void) { return &BLKIO_FILE_VT; }
/**
* @brief Open the underlying file and populate the device handle.
*
* Opens @c st->path with @c O_RDONLY or @c O_RDWR|O_CREAT depending on
* @c st->read_only. Derives @c total_blocks from the file size if the state
* value is 0 — the file size must then be a multiple of @c fbs. Sets
* @c dev->state, @c dev->forth_block_size, and @c dev->total_blocks on success.
*
* @param dev Uninitialised device handle
* @param p Parameters including the pre-initialised opaque state pointer
* @return @c BLKIO_OK on success, @c BLKIO_EIO or @c BLKIO_EINVAL on failure
*/
static int file_open(blkio_dev_t *dev, const blkio_params_t *p) {
if (!dev || !p || !p->opaque) return BLKIO_EINVAL;
blkio_file_state_t *st = (blkio_file_state_t *) p->opaque;
if (st->fd != -1) {
close(st->fd);
st->fd = -1;
}
int oflags = st->read_only ? O_RDONLY : O_RDWR;
if (!st->read_only) oflags |= O_CREAT;
#ifdef O_CLOEXEC
oflags |= O_CLOEXEC;
#endif
const int fd = open(st->path, oflags, 0644);
if (fd < 0) return BLKIO_EIO;
st->fd = fd;
struct stat sb;
if (fstat(fd, &sb) < 0) {
close(fd);
st->fd = -1;
return BLKIO_EIO;
}
/* If caller didn’t specify blocks, derive from file size (must be multiple of fbs). */
if (st->total_blocks == 0) {
if (st->fbs == 0) {
close(fd);
st->fd = -1;
return BLKIO_EINVAL;
}
if ((uint64_t) sb.st_size % (uint64_t) st->fbs != 0) {
close(fd);
st->fd = -1;
return BLKIO_EINVAL;
}
uint64_t blocks = (uint64_t) sb.st_size / (uint64_t) st->fbs;
if (blocks == 0 || blocks > 0xffffffffULL) {
close(fd);
st->fd = -1;
return BLKIO_EINVAL;
}
st->total_blocks = (uint32_t) blocks;
}
dev->state = st;
dev->forth_block_size = st->fbs;
dev->total_blocks = st->total_blocks;
return BLKIO_OK;
}
/**
* @brief Close the file descriptor held by the device.
*
* @param dev Device handle (must have valid state)
* @return @c BLKIO_OK on success, @c BLKIO_EIO if @c close() fails
*/
static int file_close(blkio_dev_t *dev) {
if (!dev || !dev->state) return BLKIO_EINVAL;
blkio_file_state_t *st = (blkio_file_state_t *) dev->state;
if (st->fd >= 0) {
int rc = close(st->fd);
st->fd = -1;
return (rc == 0) ? BLKIO_OK : BLKIO_EIO;
}
return BLKIO_OK;
}
/**
* @brief Read one FORTH block from the file backend.
*
* @param dev Open file device
* @param fblock Logical block number (must be < @c dev->total_blocks)
* @param dst Destination buffer (must be >= @c fbs bytes)
* @return @c BLKIO_OK, @c BLKIO_EINVAL if @c fblock is out of range, or @c BLKIO_EIO
*/
static int file_read(blkio_dev_t *dev, uint32_t fblock, void *dst) {
if (!dev || !dst) return BLKIO_EINVAL;
if (fblock >= dev->total_blocks) return BLKIO_EINVAL;
blkio_file_state_t *st = (blkio_file_state_t *) dev->state;
if (st->fd < 0) return BLKIO_ECLOSED;
const off_t off = (off_t)((uint64_t) fblock * (uint64_t) st->fbs);
if (full_read_at(st->fd, dst, st->fbs, off) < 0) return BLKIO_EIO;
return BLKIO_OK;
}
/**
* @brief Write one FORTH block to the file backend.
*
* @param dev Open file device (must not be read-only)
* @param fblock Logical block number (must be < @c dev->total_blocks)
* @param src Source buffer (must be >= @c fbs bytes)
* @return @c BLKIO_OK, @c BLKIO_ENOSUP if read-only, @c BLKIO_EINVAL if out of range,
* or @c BLKIO_EIO on write failure
*/
static int file_write(blkio_dev_t *dev, uint32_t fblock, const void *src) {
if (!dev || !src) return BLKIO_EINVAL;
if (fblock >= dev->total_blocks) return BLKIO_EINVAL;
blkio_file_state_t *st = (blkio_file_state_t *) dev->state;
if (st->fd < 0) return BLKIO_ECLOSED;
if (st->read_only) return BLKIO_ENOSUP;
const off_t off = (off_t)((uint64_t) fblock * (uint64_t) st->fbs);
if (full_write_at(st->fd, src, st->fbs, off) < 0) return BLKIO_EIO;
return BLKIO_OK;
}
/**
* @brief Flush pending writes via @c fsync() on Linux/POSIX; no-op elsewhere.
*
* @param dev Open file device
* @return @c BLKIO_OK on success, @c BLKIO_EIO if @c fsync() fails
*/
static int file_flush(blkio_dev_t *dev) {
if (!dev) return BLKIO_EINVAL;
blkio_file_state_t *st = (blkio_file_state_t *) dev->state;
#if defined(__linux__) || defined(__APPLE__) || defined(__unix__)
if (st->fd < 0) return BLKIO_ECLOSED;
if (fsync(st->fd) < 0) return BLKIO_EIO;
return BLKIO_OK;
#else
(void) st;
return BLKIO_OK;
#endif
}
/**
* @brief Return device info for the file backend.
*
* Physical sector size is reported as 512 (best-effort guess; no ioctl used).
* Physical size in bytes comes from @c fstat().
*
* @param dev Open file device
* @param out Output struct to populate
* @return @c BLKIO_OK on success, @c BLKIO_EIO if @c fstat() fails
*/
static int file_info(blkio_dev_t *dev, blkio_info_t *out) {
if (!dev || !out) return BLKIO_EINVAL;
blkio_file_state_t *st = (blkio_file_state_t *) dev->state;
struct stat sb;
if (fstat(st->fd, &sb) < 0) return BLKIO_EIO;
out->forth_block_size = st->fbs;
out->total_blocks = st->total_blocks;
out->phys_sector_size = 512; // best-effort guess
out->phys_size_bytes = (uint64_t) sb.st_size;
out->read_only = st->read_only;
return BLKIO_OK;
}
v3/src/blkio_ram.c
+237
View File
@@ -0,0 +1,237 @@
/*
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.
*/
// -----------------------------------------------------------------------------
// StarForth - RAM Block I/O backend
// -----------------------------------------------------------------------------
#include "blkio.h"
#include <string.h>
typedef struct {
uint8_t *base;
uint32_t total_blocks;
uint32_t fbs;
uint8_t read_only;
} blkio_ram_state_t;
/**
* @brief Return the byte size required for a @c blkio_ram_state_t.
* @return sizeof(blkio_ram_state_t)
*/
size_t blkio_ram_state_size(void) { return sizeof(blkio_ram_state_t); }
/**
* @brief Initialise a @c blkio_ram_state_t in caller-provided memory.
*
* Stores @c base, @c total_blocks, @c fbs (defaulting to
* @c BLKIO_FORTH_BLOCK_SIZE if zero), and @c read_only into the state struct
* at @c state_mem. Sets @c *out_opaque to point to the state. The caller
* owns the @c base memory and must ensure it remains valid for the device lifetime.
*
* @param state_mem Caller-allocated buffer (must be >= blkio_ram_state_size())
* @param state_len Size of @c state_mem in bytes
* @param base Pointer to the RAM block array
* @param total_blocks Number of FORTH blocks in @c base
* @param fbs FORTH block size in bytes (0 = use default)
* @param read_only 1 = deny writes, 0 = allow reads and writes
* @param out_opaque Output: set to @c state_mem on success
* @return @c BLKIO_OK on success, @c BLKIO_EINVAL on bad arguments
*/
int blkio_ram_init_state(void *state_mem, size_t state_len,
uint8_t *base, uint32_t total_blocks,
uint32_t fbs, uint8_t read_only,
void **out_opaque) {
if (!state_mem || state_len < sizeof(blkio_ram_state_t) || !base || !out_opaque)
return BLKIO_EINVAL;
blkio_ram_state_t *st = (blkio_ram_state_t *) state_mem;
st->base = base;
st->total_blocks = total_blocks;
st->fbs = (fbs ? fbs : BLKIO_FORTH_BLOCK_SIZE);
st->read_only = read_only ? 1u : 0u;
*out_opaque = (void *) st;
return BLKIO_OK;
}
/** @brief Attach state to the device handle and validate parameters. */
static int ram_open(blkio_dev_t *dev, const blkio_params_t *p);
/** @brief Close the RAM device (no-op; caller owns the memory). */
static int ram_close(blkio_dev_t * dev);
/** @brief Read one FORTH block from the RAM array into @c dst. */
static int ram_read(blkio_dev_t *dev, uint32_t fblock, void *dst);
/** @brief Write one FORTH block from @c src into the RAM array. */
static int ram_write(blkio_dev_t *dev, uint32_t fblock, const void *src);
/** @brief Flush the RAM device — always a no-op since data is in memory. */
static int ram_flush(blkio_dev_t * dev);
/** @brief Return device info (block size, count, physical size, read-only flag). */
static int ram_info(blkio_dev_t * dev, blkio_info_t * out);
static const blkio_vtable_t BLKIO_RAM_VT = {
.open = ram_open,
.close = ram_close,
.read = ram_read,
.write = ram_write,
.flush = ram_flush,
.info = ram_info
};
/**
* @brief Return the vtable for the RAM block I/O backend.
* @return Pointer to the static @c blkio_vtable_t for RAM devices
*/
const blkio_vtable_t *blkio_ram_vtable(void) { return &BLKIO_RAM_VT; }
/**
* @brief Test whether @c fb is a valid block number for the RAM device.
* @param st RAM state (may be NULL)
* @param fb Block number to test
* @return 1 if in bounds, 0 otherwise
*/
static inline int in_bounds(const blkio_ram_state_t *st, uint32_t fb) {
return st && (fb < st->total_blocks);
}
/**
* @brief Attach the RAM state to the device handle.
*
* Validates that @c base and @c fbs are non-zero, then sets
* @c dev->state, @c dev->forth_block_size, and @c dev->total_blocks.
*
* @param dev Uninitialised device handle
* @param p Parameters with pre-initialised opaque RAM state pointer
* @return @c BLKIO_OK on success, @c BLKIO_EINVAL on bad arguments
*/
static int ram_open(blkio_dev_t *dev, const blkio_params_t *p) {
if (!dev || !p || !p->opaque) return BLKIO_EINVAL;
blkio_ram_state_t *st = (blkio_ram_state_t *) p->opaque;
if (!st->base || st->fbs == 0) return BLKIO_EINVAL;
dev->state = st;
dev->forth_block_size = st->fbs;
dev->total_blocks = st->total_blocks;
return BLKIO_OK;
}
/**
* @brief Close the RAM device — caller retains ownership of the RAM buffer.
*
* @param dev Device handle
* @return @c BLKIO_OK always (no resources to release)
*/
static int ram_close(blkio_dev_t *dev) {
if (!dev || !dev->state) return BLKIO_EINVAL;
return BLKIO_OK; /* caller owns memory */
}
/**
* @brief Copy one FORTH block from the RAM array to @c dst.
*
* @param dev Open RAM device
* @param fblock Logical block number (must be < @c total_blocks)
* @param dst Destination buffer (must be >= @c fbs bytes)
* @return @c BLKIO_OK on success, @c BLKIO_EINVAL if out of range or NULL pointer
*/
static int ram_read(blkio_dev_t *dev, uint32_t fblock, void *dst) {
if (!dev || !dst) return BLKIO_EINVAL;
blkio_ram_state_t *st = (blkio_ram_state_t *) dev->state;
if (!in_bounds(st, fblock)) return BLKIO_EINVAL;
const uint8_t *src = st->base + ((size_t) fblock * st->fbs);
memcpy(dst, src, st->fbs);
return BLKIO_OK;
}
/**
* @brief Copy one FORTH block from @c src into the RAM array.
*
* @param dev Open RAM device (must not be read-only)
* @param fblock Logical block number (must be < @c total_blocks)
* @param src Source buffer (must be >= @c fbs bytes)
* @return @c BLKIO_OK on success, @c BLKIO_ENOSUP if read-only,
* @c BLKIO_EINVAL if out of range or NULL pointer
*/
static int ram_write(blkio_dev_t *dev, uint32_t fblock, const void *src) {
if (!dev || !src) return BLKIO_EINVAL;
blkio_ram_state_t *st = (blkio_ram_state_t *) dev->state;
if (st->read_only) return BLKIO_ENOSUP;
if (!in_bounds(st, fblock)) return BLKIO_EINVAL;
uint8_t *dst = st->base + ((size_t) fblock * st->fbs);
memcpy(dst, src, st->fbs);
return BLKIO_OK;
}
/**
* @brief Flush the RAM device — no-op since data is always in memory.
*
* @param dev Device handle (unused)
* @return @c BLKIO_OK always
*/
static int ram_flush(blkio_dev_t *dev) {
(void) dev;
return BLKIO_OK;
}
/**
* @brief Return device info for the RAM backend.
*
* Physical sector size equals @c fbs (RAM has no physical sector constraint).
* Physical size in bytes = @c fbs * @c total_blocks.
*
* @param dev Open RAM device
* @param out Output struct to populate
* @return @c BLKIO_OK on success, @c BLKIO_EINVAL if @c dev or @c out is NULL
*/
static int ram_info(blkio_dev_t *dev, blkio_info_t *out) {
if (!dev || !out) return BLKIO_EINVAL;
blkio_ram_state_t *st = (blkio_ram_state_t *) dev->state;
out->forth_block_size = st->fbs;
out->total_blocks = st->total_blocks;
out->phys_sector_size = st->fbs;
out->phys_size_bytes = (uint64_t) st->fbs * (uint64_t) st->total_blocks;
out->read_only = st->read_only;
return BLKIO_OK;
}
v3/src/block_subsystem.c
+1699
View File
File diff suppressed because it is too large Load Diff
v3/src/cli.c
+238
View File
@@ -0,0 +1,238 @@
/*
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 <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "cli.h"
#include "version.h"
/* Parse helper for --ram-disk */
static int parse_u32(const char* s, uint32_t* out)
{
if (!s || !*s) return -1;
uint64_t v = 0;
for (const char* p = s; *p; ++p)
{
if (*p < '0' || *p > '9') return -1;
v = v * 10u + (uint32_t)(*p - '0');
if (v > 0xffffffffULL) return -1;
}
*out = (uint32_t)v;
return 0;
}
/**
* @brief Print usage/help information
*/
void cli_print_usage(const char* program_name)
{
printf("Usage: %s [OPTIONS]\n", program_name);
printf("StarForth - A lightweight Forth virtual machine\n\n");
printf("Options:\n");
printf(" -s Script/silent mode - suppress prompts and 'ok' output (for piped input)\n");
printf(" --break-me 🔥 ULTRA-COMPREHENSIVE diagnostic mode - tests EVERYTHING\n");
printf(" --benchmark [N] Run performance benchmarks (default: 1000 iterations)\n");
printf(" --log-error Set logging level to ERROR (only errors)\n");
printf(" --log-warn Set logging level to WARN (warnings and errors)\n");
printf(" --log-info Set logging level to INFO (default)\n");
printf(" --log-test Set logging level to TEST (test results_run_01_2025_12_08 only)\n");
printf(" --log-debug Set logging level to DEBUG (all messages)\n");
printf(" --log-none Disable all logging (maximum performance)\n");
printf(" --fail-fast Stop test suite immediately on first failure\n");
printf(" --doe Run DoE experiment: output CSV metrics to stdout and exit\n");
printf(" --heartbeat-log=<mode> Heartbeat logging mode (off|summary|full)\n");
printf(" off: No heartbeat output (default)\n");
printf(" summary: Bucket aggregates in main CSV\n");
printf(" full: Per-tick CSV to hb/run-<id>.csv\n");
printf(" --disk-img=<path> Use raw disk image file at <path>\n");
printf(" --ram-disk=<MB> RAM fallback size if no --disk-img (default: 1 MB)\n");
printf(" --version, -v Show version information and exit\n");
printf(" --help, -h Show this help message\n\n");
printf("Examples:\n");
printf(" %s # Start REPL with INFO logging\n", program_name);
printf(" %s -s < script.forth # Run script from stdin (no prompts)\n", program_name);
printf(" %s --benchmark # Run benchmarks with 1000 iterations\n", program_name);
printf(" %s --disk-img=./disks/starship.img # Use disk image\n", program_name);
}
/**
* @brief Parse command-line arguments into CLIConfig
*/
CLIConfig cli_parse(int argc, char* argv[])
{
CLIConfig config = {
/* Test modes - all default to 0 */
.run_tests = 0,
.break_me = 0,
.fail_fast = 0,
.run_tests_flag_observed = 0,
/* Benchmark */
.benchmark = 0,
.benchmark_iterations = 1000,
/* Design of Experiments */
.doe_experiment = 0,
.heartbeat_log_mode = HEARTBEAT_LOG_OFF,
/* REPL mode */
.script_mode = 0,
/* Logging */
.log_level = LOG_INFO,
.log_level_explicitly_set = 0,
/* Block I/O */
.disk_img_path = NULL,
.ram_disk_mb = 1,
};
for (int i = 1; i < argc; i++)
{
if (strcmp(argv[i], "--run-tests") == 0)
{
config.run_tests_flag_observed = 1;
}
else if (strcmp(argv[i], "--break-me") == 0)
{
config.break_me = 1;
}
else if (strcmp(argv[i], "--benchmark") == 0)
{
config.benchmark = 1;
if (i + 1 < argc && atoi(argv[i + 1]) > 0)
{
config.benchmark_iterations = atoi(argv[i + 1]);
i++;
}
}
else if (strcmp(argv[i], "--log-error") == 0)
{
config.log_level = LOG_ERROR;
config.log_level_explicitly_set = 1;
}
else if (strcmp(argv[i], "--log-warn") == 0)
{
config.log_level = LOG_WARN;
config.log_level_explicitly_set = 1;
}
else if (strcmp(argv[i], "--log-info") == 0)
{
config.log_level = LOG_INFO;
config.log_level_explicitly_set = 1;
}
else if (strcmp(argv[i], "--log-test") == 0)
{
config.log_level = LOG_TEST;
config.log_level_explicitly_set = 1;
}
else if (strcmp(argv[i], "--log-debug") == 0)
{
config.log_level = LOG_DEBUG;
config.log_level_explicitly_set = 1;
}
else if (strcmp(argv[i], "--log-none") == 0)
{
config.log_level = LOG_NONE;
config.log_level_explicitly_set = 1;
}
else if (strcmp(argv[i], "--fail-fast") == 0)
{
config.fail_fast = 1;
}
else if (strcmp(argv[i], "--doe-experiment") == 0 || strcmp(argv[i], "--doe") == 0)
{
config.doe_experiment = 1;
}
else if (strncmp(argv[i], "--heartbeat-log=", 16) == 0)
{
const char* mode_str = argv[i] + 16;
if (strcmp(mode_str, "off") == 0) {
config.heartbeat_log_mode = HEARTBEAT_LOG_OFF;
} else if (strcmp(mode_str, "summary") == 0) {
config.heartbeat_log_mode = HEARTBEAT_LOG_SUMMARY;
} else if (strcmp(mode_str, "full") == 0) {
config.heartbeat_log_mode = HEARTBEAT_LOG_FULL;
} else {
fprintf(stderr, "Invalid --heartbeat-log value: %s (expected off|summary|full)\n", mode_str);
exit(1);
}
}
else if (strcmp(argv[i], "-s") == 0)
{
config.script_mode = 1;
}
else if (strncmp(argv[i], "--disk-img=", 11) == 0)
{
config.disk_img_path = argv[i] + 11;
}
else if (strncmp(argv[i], "--ram-disk=", 11) == 0)
{
uint32_t tmp = 0;
if (parse_u32(argv[i] + 11, &tmp) != 0 || tmp == 0)
{
fprintf(stderr, "Invalid --ram-disk value: %s (positive MB expected)\n", argv[i] + 11);
exit(1);
}
config.ram_disk_mb = tmp;
}
else if (strcmp(argv[i], "--version") == 0 || strcmp(argv[i], "-v") == 0)
{
printf("%s\n", STARFORTH_VERSION_FULL);
exit(0);
}
else if (strcmp(argv[i], "--help") == 0 || strcmp(argv[i], "-h") == 0)
{
cli_print_usage(argv[0]);
exit(0);
}
else
{
printf("Unknown option: %s\n", argv[i]);
cli_print_usage(argv[0]);
exit(1);
}
}
return config;
}
v3/src/compudynamics.c
+382
View File
@@ -0,0 +1,382 @@
/*
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 "compudynamics.h"
#include <string.h>
#include <stdlib.h>
/* ============================================================================
* Per-Level Tuning Accessors
* ============================================================================
*
* Returned by value, not exposed as addressable globals -- see the
* "Tuning knobs are returned by value" comment in compudynamics.h for why.
*/
/* Matches the constants ssm_jacquard.c/.h used before this module existed
* (SSM_SCORE_MAX, SSM_SCORE_DECAY_FACTOR_Q16, SSM_UCB_K, SSM_REWARD_GAIN,
* SSM_JOINT_WEIGHT_Q16, SSM_ANOVA_WEIGHT_Q16, SSM_ENTROPY/CV/TEMPORAL_DECAY
* thresholds) -- a lift, not a retune. id_window_depth=32 and
* locality_lookback=8 are new: they size the entity-ID history the
* deterministic locality signal replaces temporal_decay with. */
CDTuning cd_tuning_word(void)
{
CDTuning t;
/* classifier */
t.id_window_depth = 32u;
t.locality_lookback = 8u;
t.diversity_high_threshold_q16 = 49152u; /* 0.75 * 65536 */
t.volatility_high_threshold_q16 = 9830u; /* 0.15 * 65536 */
t.locality_high_threshold_q16 = 32768u; /* 0.5 * 65536 */
/* bandit */
t.num_configs = 128u; /* 7-bit L1-L7 */
t.num_regimes = 8u; /* 3-bit diversity/volatility/locality */
t.score_max = 65535u;
t.score_min = 0u;
t.score_decay_factor_q16 = 64881u; /* 0.99 * 65536 */
t.ucb_k = 6554u; /* 10% of score_max */
t.reward_gain = 16384u; /* 25% of score_max */
t.joint_weight_q16 = 49152u; /* 0.75 */
t.anova_weight_q16 = 16384u; /* 0.25 */
return t;
}
/* VM level: classifier-side parameters only, matching capsule_vm_physics.c's
* existing VM_FLEET_WINDOW_DEPTH so a future migration has a ready-made
* starting point. Bandit fields are zero and unused -- see compudynamics.h. */
CDTuning cd_tuning_vm(void)
{
CDTuning t;
/* classifier */
t.id_window_depth = 64u; /* matches VM_FLEET_WINDOW_DEPTH */
t.locality_lookback = 16u;
t.diversity_high_threshold_q16 = 49152u;
t.volatility_high_threshold_q16 = 9830u;
t.locality_high_threshold_q16 = 32768u;
/* bandit -- unused at VM level today */
t.num_configs = 0u;
t.num_regimes = 0u;
t.score_max = 0u;
t.score_min = 0u;
t.score_decay_factor_q16 = 0u;
t.ucb_k = 0u;
t.reward_gain = 0u;
t.joint_weight_q16 = 0u;
t.anova_weight_q16 = 0u;
return t;
}
/* ============================================================================
* Integer Helpers (isqrt, ln approximation)
* ============================================================================
*/
static uint32_t cd_isqrt32(uint32_t n)
{
uint32_t x, y;
if (n == 0u) return 0u;
x = n;
y = (x + 1u) / 2u;
while (y < x) {
x = y;
y = (x + n / x) / 2u;
}
return x;
}
static uint64_t cd_isqrt64(uint64_t n)
{
uint64_t x, y;
if (n == 0u) return 0u;
x = n;
y = (x + 1u) / 2u;
while (y < x) {
x = y;
y = (x + n / x) / 2u;
}
return x;
}
/* floor(log2(n)) * ln(2) * 65536, integer shifts only. See ssm_jacquard.c's
* former ln_approx_q16 -- identical algorithm, moved here so the generic
* bandit doesn't depend on ssm_jacquard.c. */
static uint32_t cd_ln_approx_q16(uint32_t n)
{
uint32_t bits, tmp;
if (n <= 1u) return 0u;
bits = 0u;
tmp = n >> 1u;
while (tmp > 0u) { tmp >>= 1u; bits++; }
return bits * 45426u;
}
/* ============================================================================
* Deterministic Regime Classification
* ============================================================================
*/
CDRegimeMetrics cd_classify_ids(const uint32_t *ids, uint32_t count,
uint32_t locality_lookback)
{
CDRegimeMetrics m;
uint32_t n, i, j, distinct, lookback;
uint8_t counted[CD_MAX_CLASSIFY_DEPTH];
uint32_t per_id_count[CD_MAX_CLASSIFY_DEPTH];
m.diversity_q16 = 0u;
m.volatility_q16 = 0u;
m.locality_q16 = 0u;
if (!ids || count == 0u) return m;
n = (count > CD_MAX_CLASSIFY_DEPTH) ? CD_MAX_CLASSIFY_DEPTH : count;
memset(counted, 0, n * sizeof(counted[0]));
/* --- Diversity: distinct IDs / n, and per-ID touch counts for the
* volatility pass below (single O(n^2) sweep, n <= 64) --- */
distinct = 0u;
for (i = 0u; i < n; i++) {
uint32_t c;
if (counted[i]) continue;
c = 1u;
counted[i] = 1u;
for (j = i + 1u; j < n; j++) {
if (ids[j] == ids[i]) { c++; counted[j] = 1u; }
}
per_id_count[distinct] = c;
distinct++;
}
m.diversity_q16 = (uint32_t)(((uint64_t)distinct * 65536u) / n);
/* --- Volatility: coefficient of variation of per-ID touch counts,
* computed in Q8 to avoid overflow, result in Q16 --- */
if (distinct > 0u) {
uint32_t mean_q8 = (n << 8u) / distinct;
uint64_t sum_var_q16 = 0u;
uint64_t stddev_q8, cv_q16;
for (i = 0u; i < distinct; i++) {
int64_t diff_q8 = (int64_t)(per_id_count[i] << 8u) - (int64_t)mean_q8;
uint64_t diff2_q16 = (uint64_t)(diff_q8 * diff_q8);
sum_var_q16 += diff2_q16;
}
stddev_q8 = cd_isqrt64(sum_var_q16 / distinct);
cv_q16 = (mean_q8 > 0u) ? ((stddev_q8 * 65536u) / mean_q8) : 0u;
m.volatility_q16 = (cv_q16 > 0xFFFFFFFFu) ? 0xFFFFFFFFu : (uint32_t)cv_q16;
}
/* --- Locality: fraction of touches (from lookback..n-1) that repeat
* an ID seen within the preceding lookback touches --- */
lookback = (locality_lookback > n) ? n : locality_lookback;
if (n > lookback && lookback > 0u) {
uint32_t matches = 0u;
uint32_t denom = n - lookback;
for (i = lookback; i < n; i++) {
for (j = i - lookback; j < i; j++) {
if (ids[j] == ids[i]) { matches++; break; }
}
}
m.locality_q16 = (uint32_t)(((uint64_t)matches * 65536u) / denom);
}
return m;
}
/* ============================================================================
* Generic UCB1 Config-Space Bandit
* ============================================================================
*/
int cd_config_table_init(CDConfigTable *table, const CDTuning *tuning)
{
if (!table || !tuning) return -1;
memset(table, 0, sizeof(*table));
if (tuning->num_configs == 0u || tuning->num_regimes == 0u) return -1;
table->entries = (CDConfigEntry *)malloc(tuning->num_configs * sizeof(CDConfigEntry));
table->regime_scores = (uint32_t *)malloc(
(size_t)tuning->num_regimes * tuning->num_configs * sizeof(uint32_t));
table->regime_ticks = (uint32_t *)malloc(
(size_t)tuning->num_regimes * tuning->num_configs * sizeof(uint32_t));
table->total_regime_ticks = (uint32_t *)malloc(tuning->num_regimes * sizeof(uint32_t));
if (!table->entries || !table->regime_scores || !table->regime_ticks ||
!table->total_regime_ticks) {
cd_config_table_free(table);
return -1;
}
table->num_configs = tuning->num_configs;
table->num_regimes = tuning->num_regimes;
return 0;
}
void cd_config_table_free(CDConfigTable *table)
{
if (!table) return;
free(table->entries);
free(table->regime_scores);
free(table->regime_ticks);
free(table->total_regime_ticks);
memset(table, 0, sizeof(*table));
}
void cd_config_table_seed(CDConfigTable *table, const CDTuning *tuning,
const uint32_t *initial_scores, uint8_t initial_config)
{
uint32_t c, r;
if (!table || !table->entries || !tuning || !initial_scores) return;
for (c = 0u; c < table->num_configs; c++) {
CDConfigEntry *e = &table->entries[c];
e->config_bits = (uint8_t)c;
e->has_prev = 0u;
e->_pad[0] = 0u;
e->_pad[1] = 0u;
e->benefit_score = initial_scores[c];
e->tick_count = 0u;
e->prev_window = 0u;
e->prev_locality_q16 = 0u;
for (r = 0u; r < table->num_regimes; r++) {
table->regime_scores[r * table->num_configs + c] = initial_scores[c];
table->regime_ticks[r * table->num_configs + c] = 0u;
}
}
table->current_config = initial_config;
table->current_regime = 0u;
for (r = 0u; r < table->num_regimes; r++) {
table->total_regime_ticks[r] = 0u;
}
(void)tuning;
}
uint8_t cd_config_table_tick(CDConfigTable *table, const CDTuning *tuning,
uint8_t regime, uint32_t anova_stability_q16,
int use_joint_convergence,
uint32_t current_window, uint32_t current_locality_q16)
{
uint32_t r, c;
CDConfigEntry *entry;
uint32_t combined_stability;
uint32_t *score_cell;
uint32_t old_score, decayed, new_score;
int64_t delta_score, new_s;
uint32_t total, ln_total, best_c, best_ucb, ci;
if (!table || !table->entries || !tuning) return 0u;
table->current_regime = regime;
r = (uint32_t)regime;
c = (uint32_t)table->current_config;
entry = &table->entries[c];
if (use_joint_convergence && entry->has_prev) {
uint32_t dw_raw = (current_window > entry->prev_window)
? (current_window - entry->prev_window)
: (entry->prev_window - current_window);
uint32_t dl_raw = (current_locality_q16 > entry->prev_locality_q16)
? (current_locality_q16 - entry->prev_locality_q16)
: (entry->prev_locality_q16 - current_locality_q16);
uint64_t dw_q16 = (entry->prev_window > 0u)
? (((uint64_t)dw_raw * 65536u) / entry->prev_window)
: 0u;
uint64_t dl_q16 = dl_raw; /* already Q16, bounded to [0,65536] */
uint64_t sum_sq, joint_err;
uint32_t stability;
if (dw_q16 > 65536u) dw_q16 = 65536u;
if (dl_q16 > 65536u) dl_q16 = 65536u;
/* joint_error = sqrt(dw^2 + dl^2) / sqrt(2), normalised to [0,65536] */
sum_sq = dw_q16 * dw_q16 + dl_q16 * dl_q16;
joint_err = (cd_isqrt64(sum_sq) * 65536u) / 92682u; /* sqrt(2)*65536 ~= 92682 */
if (joint_err > 65536u) joint_err = 65536u;
stability = (uint32_t)(65536u - (uint32_t)joint_err);
combined_stability = (uint32_t)(
((uint64_t)tuning->joint_weight_q16 * stability +
(uint64_t)tuning->anova_weight_q16 * anova_stability_q16) / 65536u
);
} else {
combined_stability = anova_stability_q16;
}
delta_score = ((int64_t)combined_stability - 32768) *
(int64_t)tuning->reward_gain / 32768;
score_cell = &table->regime_scores[r * table->num_configs + c];
old_score = *score_cell;
decayed = (uint32_t)(((uint64_t)old_score * tuning->score_decay_factor_q16) / 65536u);
new_s = (int64_t)decayed + delta_score;
if (new_s < (int64_t)tuning->score_min) new_score = tuning->score_min;
else if (new_s > (int64_t)tuning->score_max) new_score = tuning->score_max;
else new_score = (uint32_t)new_s;
*score_cell = new_score;
table->regime_ticks[r * table->num_configs + c]++;
if (table->total_regime_ticks[r] < 0xFFFFFFFFu) table->total_regime_ticks[r]++;
entry->tick_count++;
entry->prev_window = current_window;
entry->prev_locality_q16 = current_locality_q16;
entry->has_prev = 1u;
/* --- UCB1: select best config for the next tick --- */
total = table->total_regime_ticks[r];
ln_total = cd_ln_approx_q16(total > 0u ? total : 1u);
best_c = 0u;
best_ucb = 0u;
for (ci = 0u; ci < table->num_configs; ci++) {
uint32_t nc = table->regime_ticks[r * table->num_configs + ci];
uint32_t ucb;
if (nc == 0u) {
ucb = tuning->score_max;
} else {
uint32_t ratio = ln_total / nc;
uint32_t sqrt_r = cd_isqrt32(ratio);
uint32_t bonus = (uint32_t)(((uint64_t)tuning->ucb_k * sqrt_r) / 256u);
uint32_t sc = table->regime_scores[r * table->num_configs + ci];
ucb = sc + bonus;
if (ucb > tuning->score_max) ucb = tuning->score_max;
}
if (ucb > best_ucb) { best_ucb = ucb; best_c = ci; }
}
table->current_config = (uint8_t)best_c;
return table->entries[best_c].config_bits;
}
void cd_config_table_force(CDConfigTable *table, uint8_t config_idx)
{
if (!table || !table->entries) return;
if ((uint32_t)config_idx >= table->num_configs) return;
table->current_config = config_idx;
}
v3/src/dictionary_heat_optimization.c
+400
View File
@@ -0,0 +1,400 @@
/*
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.
*/
/*
*** StarForth ***
dictionary_heat_optimization.c - Phase 2: Heat-Aware Dictionary Lookup Optimization
Implements inference-driven dictionary lookup optimizations based on execution
heat patterns. Uses rolling window to understand which words are hot and how they
co-execute, then reorganizes the dictionary to optimize lookup performance.
*/
#include <string.h>
#include <stdlib.h>
#include <stdio.h>
#include "vm.h"
#include "rolling_window_of_truth.h"
#include "dictionary_heat_optimization.h"
#include "log.h"
#include "platform_time.h"
/* sf_fc_list/sf_fc_count/sf_fc_cap are declared in dictionary_heat_optimization.h */
/* ============================================================================
* Heat Percentile Calculation
* ============================================================================
*/
/**
* @brief qsort comparator for @c cell_t execution-heat values in ascending order.
*
* Compares two @c cell_t values passed as @c const @c void* pointers (the
* signature required by @c qsort). Returns −1, 0, or +1 following C standard
* three-way comparison convention. Used exclusively by
* @c dict_update_heat_percentiles() to sort the scratch @c heats[] array
* before computing the 25th, 50th, and 75th percentile thresholds.
*
* @param a Pointer to the first @c cell_t value.
* @param b Pointer to the second @c cell_t value.
* @return −1 if @p *a < @p *b; +1 if @p *a > @p *b; 0 if equal.
*/
static int compare_heat_ascending(const void *a, const void *b) {
cell_t heat_a = *(const cell_t *)a;
cell_t heat_b = *(const cell_t *)b;
if (heat_a < heat_b) return -1;
if (heat_a > heat_b) return 1;
return 0;
}
/**
* @brief Collect dictionary execution heats and compute the 25th, 50th, and 75th percentiles.
*
* Traverses the full linked-list dictionary under @c vm->dict_lock to snapshot
* every word's @c execution_heat into a stack-allocated scratch array (up to
* @c DICTIONARY_SIZE entries). After releasing the lock it sorts the snapshot
* with @c qsort + @c compare_heat_ascending and computes percentile indices
* using integer arithmetic:
* @code
* vm->heat_threshold_25th = heats[(count * 25) / 100];
* vm->heat_threshold_50th = heats[(count * 50) / 100];
* vm->heat_threshold_75th = heats[(count * 75) / 100];
* @endcode
*
* If the dictionary contains no words all three thresholds are set to 0.
* The lock is held only during traversal; sorting is performed outside the
* critical section to minimise contention with the concurrent heartbeat decay
* sweep that also walks the word list.
*
* The resulting thresholds are consumed by @c dict_find_word_heat_aware()
* (which stratifies its search by heat tier) and by
* @c dict_adaptive_optimization_pass() (which calls this function as its
* first step every ~1 Hz).
*
* @param vm The VM whose dictionary is sampled and whose
* @c heat_threshold_25th / @c heat_threshold_50th /
* @c heat_threshold_75th fields are updated. No-op if NULL.
*/
void dict_update_heat_percentiles(VM *vm) {
if (!vm) return;
/* Collect all heats from dictionary */
cell_t heats[DICTIONARY_SIZE];
int count = 0;
/* Protect traversal against concurrent heartbeat decay sweeps */
sf_mutex_lock(&vm->dict_lock);
for (DictEntry *w = vm->latest; w && count < DICTIONARY_SIZE; w = w->link) {
heats[count++] = w->execution_heat;
}
sf_mutex_unlock(&vm->dict_lock);
if (count == 0) {
vm->heat_threshold_25th = 0;
vm->heat_threshold_50th = 0;
vm->heat_threshold_75th = 0;
return;
}
/* Sort heats in ascending order */
qsort(heats, count, sizeof(cell_t), compare_heat_ascending);
/* Calculate percentiles */
vm->heat_threshold_25th = heats[(count * 25) / 100];
vm->heat_threshold_50th = heats[(count * 50) / 100];
vm->heat_threshold_75th = heats[(count * 75) / 100];
log_message(LOG_DEBUG,
"Heat percentiles: 25th=%ld, 50th=%ld, 75th=%ld (from %d words)",
vm->heat_threshold_25th,
vm->heat_threshold_50th,
vm->heat_threshold_75th,
count);
}
/* ============================================================================
* Heat-Aware Lookup Strategy
* ============================================================================
*/
/**
* @brief Three-pass heat-stratified dictionary lookup, hottest tier first.
*
* Searches the first-character bucket @c sf_fc_list[(unsigned char)name[0]]
* for a word whose @c name and @c name_len match @p name / @p len, scanning
* in three priority tiers ordered by execution heat:
*
* -# **Hot pass** (heat ≥ @c heat_threshold_75th): words in the top 25%
* by execution frequency. Most FORTH programs spend the vast majority of
* ticks in a handful of hot primitives; checking this tier first yields a
* near-constant-time hit on steady-state workloads.
* -# **Medium pass** (heat in [threshold_25th, threshold_75th)): the middle
* 50% of words. These are occasionally-called words that still appear often
* enough to warrant a dedicated pass before touching the long tail.
* -# **Cold pass** (heat < @c heat_threshold_25th): the rarely-executed
* bottom quartile. Words that have never been called also live here.
*
* Within each pass, matching uses the same cheap-first filter chain as the
* standard lookup: @c name_len comparison → last-character byte check →
* full @c memcmp. The last-character pre-filter is skipped for single-character
* names.
*
* Returns @c NULL only if the word is absent from the bucket; all three passes
* exhausted without a hit. Also returns @c NULL immediately if @p vm, @p name,
* or @p len are invalid.
*
* Heat thresholds are updated lazily by @c dict_adaptive_optimization_pass()
* (≈1 Hz); stale thresholds degrade to a full three-pass scan without
* affecting correctness.
*
* @param vm The VM; provides @c heat_threshold_* fields and the bucket table.
* @param name Word name to search for (not NUL-terminated; length in @p len).
* @param len Length of @p name in bytes; must be ≥ 1.
* @return Pointer to the matching @c DictEntry, or @c NULL if not found.
*/
DictEntry *dict_find_word_heat_aware(VM *vm, const char *name, size_t len) {
if (!vm || !name || len == 0) return NULL;
const unsigned char first = (unsigned char)name[0];
DictEntry **bucket = sf_fc_list[first];
size_t n = sf_fc_count[first];
if (!bucket || n == 0) return NULL;
/* Resolution must be arbitrated: the heat-stratified three-pass scan
* returned the first name match in tier order, which resolves shadowed
* (redefined) names by execution heat instead of definition age — a
* FORTH-79 semantics violation that dict_reorganize_buckets_by_heat()
* turns into a live fault (see VM-COUNT primitive/constant collision,
* logs/20260704-155745). The strategy selection between naive and
* heat-aware lookup is preserved; both now resolve through the same
* age-honoring scan. A stratified fast path may be reintroduced on top
* of the resolver if lookup latency ever warrants it. */
return vm_dict_resolve_in_bucket(vm, bucket, n, name, len);
}
/* ============================================================================
* Bucket Reorganization by Heat Patterns
* ============================================================================
*/
/**
* @brief qsort comparator for @c DictEntry* pointers in descending execution-heat order.
*
* Dereferences two @c DictEntry** pointers and compares their
* @c execution_heat fields, returning −1 if the first entry is hotter,
* +1 if the second is hotter, or 0 on a tie. Used exclusively by
* @c dict_reorganize_buckets_by_heat() to sort each of the 256 first-character
* hash buckets so that hot words appear at lower array indices, reducing the
* average scan depth during the medium and cold passes of
* @c dict_find_word_heat_aware().
*
* @param a Pointer to a @c DictEntry* (first element).
* @param b Pointer to a @c DictEntry* (second element).
* @return −1 if @p a is hotter; +1 if @p b is hotter; 0 if equal.
*/
static int compare_dict_entry_heat_desc(const void *a, const void *b) {
DictEntry *entry_a = *(DictEntry * const *)a;
DictEntry *entry_b = *(DictEntry * const *)b;
if (entry_a->execution_heat > entry_b->execution_heat) return -1;
if (entry_a->execution_heat < entry_b->execution_heat) return 1;
return 0;
}
/**
* @brief Sort all 256 first-character hash buckets by descending execution heat.
*
* Holds @c vm->dict_lock for the entire operation to prevent concurrent
* @c DictEntry frees (from word redefinition or GC) from invalidating the
* pointer array while it is being sorted. For each non-empty bucket in
* @c sf_fc_list[0..255]:
*
* 1. Reads @c sf_fc_count[bucket_id] and @c sf_fc_cap[bucket_id]; skips the
* bucket if @c count > @c cap (indicates a TOCTOU race — logs a warning).
* 2. Allocates a temporary copy of the bucket pointer array.
* 3. Re-verifies @c count has not changed (TOCTOU double-check); if it has,
* frees the copy and skips.
* 4. Sorts the copy with @c qsort + @c compare_dict_entry_heat_desc so that
* the hottest @c DictEntry* comes first.
* 5. Copies the sorted array back over the original bucket.
* 6. Frees the temporary copy.
*
* After returning, @c vm->last_bucket_reorg_ns is updated to the completion
* timestamp so that @c dict_adaptive_optimization_pass() can enforce its 1 Hz
* throttle. The elapsed reorganization time is emitted at @c LOG_DEBUG.
*
* @param vm The VM whose first-character hash buckets are reorganized.
* No-op if NULL. @c dict_lock is held during the entire scan.
*/
void dict_reorganize_buckets_by_heat(VM *vm) {
if (!vm) return;
uint64_t reorg_start = sf_monotonic_ns();
/* Race fix: Hold dict_lock during entire reorganization (2025-12-09)
* Without this, main thread can free DictEntry objects while we're sorting pointers */
sf_mutex_lock(&vm->dict_lock);
/* Reorganize each bucket by heat (hottest words first) */
for (int bucket_id = 0; bucket_id < 256; bucket_id++) {
if (!sf_fc_list[bucket_id] || sf_fc_count[bucket_id] == 0) continue;
/* ASan fix: Verify count doesn't exceed capacity before accessing (2025-12-09)
* Race condition: Main thread may have changed count/capacity while we read it */
size_t count = sf_fc_count[bucket_id];
size_t cap = sf_fc_cap[bucket_id];
if (count > cap) {
log_message(LOG_WARN,
"dict_reorganize_buckets_by_heat: skipping bucket %d - count=%zu exceeds capacity=%zu (race condition)",
bucket_id, count, cap);
continue;
}
/* Make a copy of bucket pointers */
DictEntry **bucket_copy = malloc(count * sizeof(DictEntry *));
if (!bucket_copy) continue;
/* Re-verify count hasn't changed (TOCTOU protection) */
size_t count_recheck = sf_fc_count[bucket_id];
if (count_recheck != count || count_recheck > cap) {
log_message(LOG_WARN,
"dict_reorganize_buckets_by_heat: bucket %d count changed (%zu -> %zu), aborting",
bucket_id, count, count_recheck);
free(bucket_copy);
continue;
}
memcpy(bucket_copy, sf_fc_list[bucket_id], count * sizeof(DictEntry *));
/* Sort by descending heat (use cached count to avoid TOCTOU race) */
qsort(bucket_copy, count, sizeof(DictEntry *),
compare_dict_entry_heat_desc);
/* Copy back to original bucket (still use cached count) */
memcpy(sf_fc_list[bucket_id], bucket_copy, count * sizeof(DictEntry *));
free(bucket_copy);
}
sf_mutex_unlock(&vm->dict_lock);
uint64_t reorg_end = sf_monotonic_ns();
vm->last_bucket_reorg_ns = reorg_end;
log_message(LOG_DEBUG,
"Dictionary buckets reorganized by heat in %.1f μs",
(double)(reorg_end - reorg_start) / 1000.0);
}
/* ============================================================================
* Adaptive Optimization Pass
* ============================================================================
*/
/**
* @brief Throttled adaptive optimization pass — runs at most once per second.
*
* Called from the interpreter loop (or heartbeat) on every word dispatch; the
* 1 Hz gate (@c now_ns - @c vm->last_bucket_reorg_ns < 1,000,000,000) ensures
* the three expensive sub-steps run at a rate that is imperceptible to FORTH
* execution while still keeping the dictionary layout fresh:
*
* 1. **Update heat percentiles** — calls @c dict_update_heat_percentiles() to
* re-sample @c execution_heat across all words and compute the 25th / 50th /
* 75th thresholds used by the stratified lookup.
*
* 2. **Reorganize buckets** — calls @c dict_reorganize_buckets_by_heat() to
* sort each of the 256 first-character hash buckets so that the hottest
* words sit at the lowest array indices, shortening the average scan depth
* during the hot-tier pass.
*
* 3. **Select lookup strategy** — queries the rolling window for the current
* pattern-diversity score via @c rolling_window_measure_diversity():
* - Diversity > 70 (high churn in which words are called) → strategy 1
* (@c heat-aware lookup, @c dict_find_word_heat_aware()), where the heat
* stratification most pays off.
* - Diversity ≤ 70 (stable repetitive pattern) → strategy 0 (naive
* newest-first bucket scan), which is already nearly O(1) for programs
* that call the same small word set repeatedly.
* The chosen strategy is stored in @c vm->lookup_strategy and read by the
* interpreter's dictionary lookup dispatch.
*
* @param vm The VM to optimise. No-op if NULL or if less than 1 second has
* elapsed since the last pass (@c vm->last_bucket_reorg_ns).
*/
void dict_adaptive_optimization_pass(VM *vm) {
if (!vm) return;
uint64_t now_ns = sf_monotonic_ns();
/* Run optimization every 1 second */
if (now_ns - vm->last_bucket_reorg_ns < 1000000000ULL) {
return; /* Too soon, skip */
}
/* Step 1: Update heat percentiles based on current dictionary state */
dict_update_heat_percentiles(vm);
/* Step 2: Reorganize buckets by heat order (hot words first) */
dict_reorganize_buckets_by_heat(vm);
/* Step 3: Select lookup strategy based on pattern diversity */
uint64_t pattern_diversity = rolling_window_measure_diversity(&vm->rolling_window);
/* High diversity (0.7+): Use heat-aware lookup (patterns change frequently) */
if (pattern_diversity > 70) {
vm->lookup_strategy = 1; /* Heat-aware */
log_message(LOG_DEBUG,
"High pattern diversity (%.0f%%), using heat-aware lookup",
(double)pattern_diversity);
}
/* Medium diversity: Use naive newest-first (patterns reasonably stable) */
else {
vm->lookup_strategy = 0; /* Naive */
log_message(LOG_DEBUG,
"Stable patterns (%.0f%% diversity), using naive lookup",
(double)pattern_diversity);
}
}
v3/src/dictionary_management.c
+600
View File
@@ -0,0 +1,600 @@
/*
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.
*/
/*
* StarForth dictionary_management.c — FORTH-79 + ANSI C99
* Optimized: incremental FC index + capacity reuse + newest-first search
*/
#include "../include/vm.h"
#include "../include/io.h"
#include "../include/log.h"
#include "../include/physics_metadata.h"
#include "../include/physics_hotwords_cache.h"
#include "../include/physics_pipelining_metrics.h"
#include "../include/dictionary_heat_optimization.h"
#include "../include/platform_alloc.h"
#include <string.h>
#include <stddef.h>
#include <stdint.h>
#ifdef __STARKERNEL__
#include "starkernel/vm/stadium_words.h" /* item 4.1: FORGET coherence hook */
#include "starkernel/vm_uuid.h" /* vm_uuid_hera() */
#endif
/* LIKELY/UNLIKELY macros are defined in vm.h */
#ifndef SF_FC_BUCKETS
#define SF_FC_BUCKETS 256
#endif
/* Buckets of entry pointers, sizes, and capacities (we reuse memory). */
/* Note: sf_fc_list, sf_fc_count, and sf_fc_cap are not static to allow access from
* dictionary_heat_optimization.c for heat-aware bucket reorganization with proper
* capacity checks (ASan fix: 2025-12-09). */
DictEntry **sf_fc_list[SF_FC_BUCKETS];
size_t sf_fc_count[SF_FC_BUCKETS];
size_t sf_fc_cap[SF_FC_BUCKETS];
static DictEntry *sf_cached_latest = NULL; /* last head we indexed */
static uint32_t vm_dictionary_acquire_word_id(VM *vm) {
if (!vm) {
return WORD_ID_INVALID;
}
if (vm->recycled_word_id_count > 0) {
return vm->recycled_word_ids[--vm->recycled_word_id_count];
}
if (vm->next_word_id < DICTIONARY_SIZE) {
return vm->next_word_id++;
}
return WORD_ID_INVALID;
}
void vm_dictionary_track_entry(VM *vm, DictEntry *entry) {
if (!vm || !entry) {
return;
}
uint32_t word_id = vm_dictionary_acquire_word_id(vm);
entry->word_id = word_id;
if (word_id == WORD_ID_INVALID || word_id >= DICTIONARY_SIZE) {
log_message(LOG_WARN,
"vm_dictionary_track_entry: out of stable IDs, disabling metrics for '%.*s'",
(int)entry->name_len, entry->name);
return;
}
vm->word_id_map[word_id] = entry;
}
void vm_dictionary_untrack_entry(VM *vm, DictEntry *entry) {
if (!vm || !entry) {
return;
}
/* Cache coherence: the entry is about to be removed (FORGET frees it) —
* a stale pointer left in the hot-words ring would be a use-after-free,
* and an older same-named word may become visible again.
* §17.3 (item 4.1): retired under __STARKERNEL__ -- the kernel word
* layer stays inert to this mechanism entirely, so there is nothing to
* keep coherent here on the kernel side. Hosted is unaffected. */
#ifndef __STARKERNEL__
hotwords_cache_evict_entry(vm->hotwords_cache, entry);
#endif
uint32_t word_id = entry->word_id;
if (word_id == WORD_ID_INVALID || word_id >= DICTIONARY_SIZE) {
return;
}
#ifdef __STARKERNEL__
/* item 4.1 coherence hook: if this word_id is resident on the Stadium,
* reclaim its cell (crediting heat back to the reservoir) BEFORE the id
* is recycled below -- otherwise the next word assigned this same id
* would alias onto the forgotten word's stale cell (same failure class
* as the 2026-08-02 block_words.c aliasing bug). */
stadium_word_forget(vm->stadium_vm_id, word_id);
#endif
if (vm->word_id_map[word_id] == entry) {
vm->word_id_map[word_id] = NULL;
}
if (vm->recycled_word_id_count < DICTIONARY_SIZE) {
vm->recycled_word_ids[vm->recycled_word_id_count++] = word_id;
}
entry->word_id = WORD_ID_INVALID;
}
DictEntry *vm_dictionary_lookup_by_word_id(VM *vm, uint32_t word_id) {
if (!vm || word_id >= DICTIONARY_SIZE) {
return NULL;
}
return vm->word_id_map[word_id];
}
int vm_dict_entry_ok(VM *vm, DictEntry *candidate) {
if (!vm || !candidate) {
return 0;
}
int found = 0;
sf_mutex_lock(&vm->dict_lock);
for (DictEntry *e = vm->latest; e != NULL; e = e->link) {
if (e == candidate) {
found = 1;
break;
}
}
sf_mutex_unlock(&vm->dict_lock);
return found;
}
/* --- helpers ------------------------------------------------------------- */
static inline void *sf_xrealloc(void *p, size_t nbytes) {
void *r = sf_realloc(p, nbytes);
if (!r) {
sf_free(p);
return NULL;
}
return r;
}
static void sf_fc_clear_all(void) {
for (size_t i = 0; i < SF_FC_BUCKETS; ++i) {
sf_free(sf_fc_list[i]);
sf_fc_list[i] = NULL;
sf_fc_count[i] = 0;
sf_fc_cap[i] = 0;
}
}
/* Ensure bucket i has at least `need` capacity; grow geometrically. */
static int sf_fc_reserve(size_t i, size_t need) {
if (sf_fc_cap[i] >= need) return 1;
size_t newcap = sf_fc_cap[i] ? sf_fc_cap[i] : 8;
while (newcap < need) newcap <<= 1;
DictEntry **old = sf_fc_list[i];
DictEntry **newv = (DictEntry **) sf_xrealloc(old, newcap * sizeof(*newv));
if (!newv) return 0;
/* Kernel sf_realloc is a bump allocator that does not copy; patch that up.
* On hosted Linux, realloc already copied before freeing old — do NOT memcpy
* from freed memory (UB; glibc overwrites freed block with heap metadata). */
#ifdef __STARKERNEL__
{
size_t old_count = sf_fc_count[i];
if (newv != old && old && old_count > 0)
memcpy(newv, old, old_count * sizeof(*newv));
}
#endif
sf_fc_list[i] = newv;
sf_fc_cap[i] = newcap;
return 1;
}
/* Full rebuild: count → reserve → fill oldest→newest (so backward scan = newest-first). */
static void sf_rebuild_fc_index(VM *vm) {
/* Reset counts, keep capacity to avoid churn. */
for (size_t i = 0; i < SF_FC_BUCKETS; ++i) sf_fc_count[i] = 0;
/* Count first chars. */
for (DictEntry *e = vm->latest; e; e = e->link) {
unsigned fc = (unsigned char) e->name[0];
sf_fc_count[fc]++;
}
/* Reserve memory once per bucket. */
for (size_t i = 0; i < SF_FC_BUCKETS; ++i) {
if (sf_fc_count[i] && !sf_fc_reserve(i, sf_fc_count[i])) {
/* OOM for this bucket → treat as empty; we’ll just miss the fast path. */
sf_fc_count[i] = 0;
}
}
/* Back-fill so [0]=oldest, [count-1]=newest. */
size_t fill_at[SF_FC_BUCKETS];
for (size_t i = 0; i < SF_FC_BUCKETS; ++i) fill_at[i] = sf_fc_count[i];
for (DictEntry *e = vm->latest; e; e = e->link) {
unsigned fc = (unsigned char) e->name[0];
if (sf_fc_count[fc] == 0 || !sf_fc_list[fc]) continue;
sf_fc_list[fc][--fill_at[fc]] = e;
}
sf_cached_latest = vm->latest;
}
/* Fast path: if exactly one new word was pushed, append it without rebuilding. */
static void sf_try_fast_append(VM *vm) {
if (!vm || vm->latest == sf_cached_latest) return;
DictEntry *newest = vm->latest;
/* single push if the new head links to the previously cached head */
if (newest && newest->link == sf_cached_latest) {
unsigned fc = (unsigned char) newest->name[0];
size_t n = sf_fc_count[fc];
if (sf_fc_reserve(fc, n + 1)) {
/* Keep oldest→…→newest ordering: append at the end. */
sf_fc_list[fc][n] = newest;
sf_fc_count[fc] = n + 1;
sf_cached_latest = newest;
return;
}
}
/* Otherwise fall back to a full rebuild (multiple changes, deletes, etc.). */
sf_rebuild_fc_index(vm);
}
/* --- API ----------------------------------------------------------------- */
/**
* @brief Return whichever of two entries is the more recent definition.
*
* Walks the definition chain from @c vm->latest; the first of (@p a, @p b)
* encountered is the newer one. The link chain is the only reliable age
* order — word_id values are recycled and bucket positions are shuffled by
* @c dict_reorganize_buckets_by_heat(), so neither can arbitrate age.
* Only invoked when a bucket holds two visible entries with the same name
* (redefinition/shadowing), so the walk cost is off the common path.
*/
static DictEntry *dict_newer_of(VM *vm, DictEntry *a, DictEntry *b) {
for (DictEntry *e = vm->latest; e; e = e->link) {
if (e == a) return a;
if (e == b) return b;
}
return a;
}
DictEntry *vm_dict_resolve_in_bucket(VM *vm, DictEntry **bucket, size_t n,
const char *name, size_t len) {
if (!vm || !bucket || n == 0 || !name || len == 0) return NULL;
const unsigned char last = (len > 1) ? (unsigned char) name[len - 1] : 0;
DictEntry *best = NULL;
/* Full scan: bucket order is heat-shuffled, so no prefix of the bucket
* is authoritative — every same-named candidate must be considered and
* the newest visible definition wins (FORTH-79 shadowing). */
for (size_t i = n; i-- > 0;) {
DictEntry *e = bucket[i];
if (!e) continue;
if ((size_t) e->name_len != len) continue;
#ifdef WORD_HIDDEN
if (UNLIKELY(e->flags & WORD_HIDDEN)) continue;
#endif
#ifdef WORD_SMUDGED
if (UNLIKELY(e->flags & WORD_SMUDGED)) continue;
#endif
if (len > 1 && (unsigned char) e->name[len - 1] != last) continue;
if (memcmp(e->name, name, len) != 0) continue;
best = best ? dict_newer_of(vm, best, e) : e;
}
return best;
}
/* Find by name: newest-first within the first-character bucket. */
/**
* @brief Finds a word in the dictionary by name
*
* Searches for a word in the dictionary using an optimized first-character index.
* The search is performed newest-first within the matching first-character bucket.
*
* @param vm The virtual machine context
* @param name The name to search for
* @param len Length of the name string
* @return DictEntry* Pointer to found dictionary entry or NULL if not found
*/
DictEntry *vm_find_word(VM *vm, const char *name, size_t len) {
if (UNLIKELY(!vm || !name || len == 0)) return NULL;
/* DoE counter: dictionary lookups */
vm->heartbeat.dictionary_lookups++;
/* Thread safety: Acquire dict_lock for read access to dictionary */
sf_mutex_lock(&vm->dict_lock);
/* Keep the index in sync with dictionary head, cheaply if possible. */
if (UNLIKELY(sf_cached_latest != vm->latest)) sf_try_fast_append(vm);
const unsigned char first = (unsigned char) name[0];
DictEntry **bucket = sf_fc_list[first];
size_t n = sf_fc_count[first];
if (UNLIKELY(!bucket || n == 0)) {
sf_mutex_unlock(&vm->dict_lock);
return NULL;
}
/* Use hot-words cache for physics-driven frequency-based acceleration.
* The cache's bucket fallback resolves via vm_dict_resolve_in_bucket(),
* so a non-NULL result already honors newest-first shadowing.
* §17.3 (item 4.1): bypassed under __STARKERNEL__ -- the kernel side
* feeds the Stadium instead (vm_core.c's dispatch sites), and this
* lookup fast path is retired in favor of the ordinary bucket scan
* below. Hosted is unaffected. */
#ifndef __STARKERNEL__
DictEntry *found = hotwords_cache_lookup(vm, vm->hotwords_cache, bucket, n, name, len);
if (found) {
sf_mutex_unlock(&vm->dict_lock);
return found;
}
#endif
/* Phase 2: Choose lookup strategy based on pattern diversity */
if (vm->lookup_strategy == 1) {
/* Heat-aware lookup: search by heat percentiles (hot first) */
DictEntry *result = dict_find_word_heat_aware(vm, name, len);
sf_mutex_unlock(&vm->dict_lock);
return result;
}
/* Fallback/Default: arbitrated scan — buckets may be heat-reordered, so
* first-match-wins is unsound; the resolver picks the newest visible
* definition among all same-named candidates. */
DictEntry *e = vm_dict_resolve_in_bucket(vm, bucket, n, name, len);
sf_mutex_unlock(&vm->dict_lock);
return e;
}
/* Create a new word (unchanged layout); index append happens lazily on next lookup. */
/**
* @brief Creates a new word in the dictionary
*
* Allocates and initializes a new dictionary entry with the given name and function.
* The word is added to the dictionary but index update is deferred until next lookup.
*
* @param vm The virtual machine context
* @param name Name for the new word
* @param len Length of the name string
* @param func Function pointer for the word's behavior
* @return DictEntry* Pointer to new dictionary entry or NULL on failure
*/
DictEntry *vm_create_word(VM *vm, const char *name, size_t len, word_func_t func) {
if (!vm || !name || len == 0 || len > WORD_NAME_MAX) {
if (vm) {
vm->error = 1;
log_message(LOG_ERROR, "vm_create_word: invalid parameters (vm=%p, name=%p, len=%zu, max=%d)",
(void *) vm, (const void *) name, len, WORD_NAME_MAX);
}
return NULL;
}
DictEntry *entry = NULL;
int lock_held = 0;
sf_mutex_lock(&vm->dict_lock);
lock_held = 1;
/* Pin is permanent: no word may shadow a pinned entry — ever, by anyone */
for (DictEntry *scan = vm->latest; scan; scan = scan->link) {
if (scan->acl_pinned && scan->name_len == (uint8_t)len &&
memcmp(scan->name, name, len) == 0) {
vm->error = 1;
log_message(LOG_WARN, "vm_create_word: cannot shadow pinned word '%.*s'",
(int)len, name);
entry = NULL;
goto create_cleanup;
}
}
size_t base = offsetof(DictEntry, name);
size_t name_bytes = len + 1;
size_t align = sizeof(cell_t);
size_t df_off = (base + name_bytes + (align - 1)) & ~(align - 1);
size_t total = df_off + sizeof(cell_t);
entry = (DictEntry *) sf_malloc(total);
if (!entry) {
vm->error = 1;
log_message(LOG_ERROR, "vm_create_word: malloc failed for '%.*s' (%zu bytes)",
(int) len, name, total);
entry = NULL;
goto create_cleanup;
}
entry->link = vm->latest;
entry->func = func;
entry->flags = 0;
entry->name_len = (uint8_t) len;
entry->execution_heat = 0; /* Initialize execution heat counter */
entry->acl_default = ACL_USER_DEFAULT;
entry->acl_ttl = 0; /* first execution always rechecks */
entry->acl_allow = 1; /* permissive until ACL.4th loads */
entry->acl_mode = ACL_MODE_TTL;
entry->acl_pinned = 0;
entry->word_id = WORD_ID_INVALID;
uint32_t header_bytes = (total > UINT32_MAX) ? UINT32_MAX : (uint32_t) total;
physics_metadata_init(entry, header_bytes);
physics_metadata_apply_seed(entry);
/* Initialize word transition metrics for pipelining (Phase 1) */
entry->transition_metrics = (WordTransitionMetrics *)sf_malloc(sizeof(WordTransitionMetrics));
if (entry->transition_metrics) {
transition_metrics_init(entry->transition_metrics);
} else {
log_message(LOG_WARN, "vm_create_word: transition metrics malloc failed for '%.*s'", (int)len, name);
}
memcpy(entry->name, name, len);
entry->name[len] = '\0';
if (df_off > base + name_bytes) {
memset(((uint8_t *) entry) + base + name_bytes, 0, df_off - (base + name_bytes));
}
*(cell_t *) (((uint8_t *) entry) + df_off) = 0;
vm->latest = entry;
vm_dictionary_track_entry(vm, entry);
/* Cache coherence: this definition may shadow an older word of the same
* name that the hot-words cache is still serving. Evict the name so the
* next lookup re-resolves through the arbitrated bucket scan.
* §17.3 (item 4.1): retired under __STARKERNEL__, same as the other
* hotwords_cache_* call sites in this file. */
#ifndef __STARKERNEL__
hotwords_cache_evict_name(vm->hotwords_cache, name, len);
#endif
log_message(LOG_DEBUG, "vm_create_word: '%.*s' len=%zu total=%zu @%p",
(int) len, name, len, total, (void *) entry);
create_cleanup:
if (lock_held)
sf_mutex_unlock(&vm->dict_lock);
return entry;
}
/* Linear scan by func (left as-is; usually cold path). */
/**
* @brief Finds a word by its function pointer
*
* Performs a linear scan of the dictionary to find an entry with matching function.
*
* @param vm The virtual machine context
* @param func Function pointer to search for
* @return DictEntry* Pointer to found dictionary entry or NULL if not found
*/
DictEntry *vm_dictionary_find_by_func(VM *vm, word_func_t func) {
for (DictEntry *e = vm ? vm->latest : NULL; e; e = e->link) {
if (e->func == func) return e;
}
return NULL;
}
DictEntry *vm_dictionary_find_latest_by_func(VM *vm, word_func_t func) {
return vm_dictionary_find_by_func(vm, func);
}
/**
* @brief Gets pointer to a word's data field
*
* Calculates and returns pointer to the aligned data field following the name field.
*
* @param entry Dictionary entry to get data field from
* @return cell_t* Pointer to data field or NULL if entry is NULL
*/
cell_t *vm_dictionary_get_data_field(DictEntry *entry) {
if (!entry) return NULL;
size_t base = offsetof(DictEntry, name);
size_t name_bytes = (size_t) entry->name_len + 1;
size_t align = sizeof(cell_t);
size_t df_off = (base + name_bytes + (align - 1)) & ~(align - 1);
return (cell_t *) (((uint8_t *) entry) + df_off);
}
/**
* @brief Marks the latest word as hidden
*
* Sets the WORD_HIDDEN flag on the most recently defined word.
*
* @param vm The virtual machine context
*/
void vm_hide_word(VM *vm) {
if (vm && vm->latest) {
vm->latest->flags |= WORD_HIDDEN;
physics_metadata_refresh_state(vm->latest);
/* Visibility changed: this name may now resolve to an older entry.
* §17.3 (item 4.1): retired under __STARKERNEL__. */
#ifndef __STARKERNEL__
hotwords_cache_evict_name(vm->hotwords_cache,
vm->latest->name, vm->latest->name_len);
#endif
}
}
void vm_smudge_word(VM *vm) {
if (!vm || !vm->latest) {
if (vm) {
vm->error = 1;
log_message(LOG_ERROR, "vm_smudge_word: invalid vm or no latest word");
}
return;
}
vm->latest->flags ^= WORD_SMUDGED;
physics_metadata_refresh_state(vm->latest);
/* Visibility changed in either direction: force re-resolution.
* §17.3 (item 4.1): retired under __STARKERNEL__. */
#ifndef __STARKERNEL__
hotwords_cache_evict_name(vm->hotwords_cache,
vm->latest->name, vm->latest->name_len);
#endif
}
void vm_pin_execution_heat(VM *vm) {
if (!vm || !vm->latest) {
if (vm) {
vm->error = 1;
log_message(LOG_ERROR, "vm_pin_execution_heat: invalid vm or no latest word");
}
return;
}
vm->latest->flags |= WORD_PINNED;
physics_metadata_refresh_state(vm->latest);
}
void vm_unpin_execution_heat(VM *vm) {
if (!vm || !vm->latest) {
if (vm) {
vm->error = 1;
log_message(LOG_ERROR, "vm_unpin_execution_heat: invalid vm or no latest word");
}
return;
}
vm->latest->flags &= ~WORD_PINNED;
physics_metadata_refresh_state(vm->latest);
}
/* If you ever need to hard-reset (e.g., switching vocabularies wholesale) */
/**
* @brief Resets the dictionary index
*
* Clears all index data and cached state. Used when switching vocabularies.
*/
void vm_dictionary_index_reset(void) {
sf_cached_latest = NULL;
sf_fc_clear_all();
}
v3/src/doe_metrics.c
+639
View File
@@ -0,0 +1,639 @@
/*
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.
*/
/**
* @file doe_metrics.c
* @brief Design of Experiments metrics collection implementation
*/
#include "doe_metrics.h"
#include "physics_hotwords_cache.h"
#include "rolling_window_of_truth.h"
#include "rolling_window_knobs.h"
#include "inference_engine.h"
#include "platform_time.h"
#include <time.h>
#include <string.h>
#include <stdio.h>
#include <stdlib.h>
#ifdef __unix__
#include <unistd.h>
#endif
/* Forward declarations from physics system */
extern struct {
uint64_t total_lookups;
uint64_t cache_hits;
uint64_t bucket_hits;
} physics_global_stats;
/**
* Get current CPU temperature in Celsius
*/
int32_t metrics_get_cpu_temp_c(void) {
#ifdef __unix__
FILE *f = fopen("/sys/class/thermal/thermal_zone0/temp", "r");
if (!f) return 0;
int temp_millidegrees = 0;
if (fscanf(f, "%d", &temp_millidegrees) != 1) {
fclose(f);
return 0;
}
fclose(f);
return (int32_t)(temp_millidegrees / 1000);
#else
return 0;
#endif
}
/**
* Get current CPU frequency in MHz
*/
int32_t metrics_get_cpu_freq_mhz(void) {
#ifdef __unix__
/* Try scaling_cur_freq first */
FILE *f = fopen("/sys/devices/system/cpu/cpu0/cpufreq/scaling_cur_freq", "r");
if (f) {
int freq_khz = 0;
if (fscanf(f, "%d", &freq_khz) == 1) {
fclose(f);
return (int32_t)(freq_khz / 1000);
}
fclose(f);
}
/* Fallback to /proc/cpuinfo */
f = fopen("/proc/cpuinfo", "r");
if (f) {
char line[256];
while (fgets(line, sizeof(line), f)) {
if (strncmp(line, "cpu MHz", 7) == 0) {
float mhz = 0.0f;
if (sscanf(line, "cpu MHz : %f", &mhz) == 1) {
fclose(f);
return (int32_t)mhz;
}
}
}
fclose(f);
}
#endif
return 0;
}
/**
* Get current timestamp as ISO 8601 string
*/
void metrics_get_timestamp(char *buf, size_t bufsize) {
if (bufsize < 32) return;
time_t now = time(NULL);
struct tm *tm_info = localtime(&now);
strftime(buf, bufsize, "%Y-%m-%dT%H:%M:%S", tm_info);
}
/**
* Extract metrics from VM hotwords cache stats
*/
static void extract_cache_metrics(const HotwordsCache *cache, DoeMetrics *metrics) {
if (!cache) {
metrics->cache_hits = 0;
metrics->cache_hit_percent = 0.0;
metrics->bucket_hits = 0;
metrics->bucket_hit_percent = 0.0;
metrics->cache_hit_latency_ns = 0;
metrics->cache_hit_stddev_ns = 0;
metrics->bucket_search_latency_ns = 0;
metrics->bucket_search_stddev_ns = 0;
return;
}
const HotwordsStats *stats = &cache->stats;
/* Cache hits */
metrics->cache_hits = stats->cache_hits;
if (stats->total_lookups > 0) {
metrics->cache_hit_percent = 100.0 * (double)stats->cache_hits / (double)stats->total_lookups;
} else {
metrics->cache_hit_percent = 0.0;
}
/* Bucket hits */
metrics->bucket_hits = stats->bucket_hits;
if (stats->total_lookups > 0) {
metrics->bucket_hit_percent = 100.0 * (double)stats->bucket_hits / (double)stats->total_lookups;
} else {
metrics->bucket_hit_percent = 0.0;
}
/* Cache hit latency (convert from Q48.16 to ns) */
if (stats->cache_hit_samples > 0) {
int64_t avg_q48 = stats->cache_hit_total_ns_q48 / (int64_t)stats->cache_hit_samples;
metrics->cache_hit_latency_ns = avg_q48 >> 16; /* Convert from Q48.16 to nanoseconds */
/* StdDev calculation from variance sum */
if (stats->cache_hit_samples > 1) {
/* Simplified: use variance sum for estimation */
int64_t variance_q48 = stats->cache_hit_variance_sum_q48 / (int64_t)stats->cache_hit_samples;
metrics->cache_hit_stddev_ns = (int64_t)(variance_q48 >> 16);
} else {
metrics->cache_hit_stddev_ns = 0;
}
} else {
metrics->cache_hit_latency_ns = 0;
metrics->cache_hit_stddev_ns = 0;
}
/* Bucket search latency (convert from Q48.16 to ns) */
if (stats->bucket_search_samples > 0) {
int64_t avg_q48 = stats->bucket_search_total_ns_q48 / (int64_t)stats->bucket_search_samples;
metrics->bucket_search_latency_ns = avg_q48 >> 16; /* Convert from Q48.16 to nanoseconds */
/* StdDev calculation from variance sum */
if (stats->bucket_search_samples > 1) {
int64_t variance_q48 = stats->bucket_search_variance_sum_q48 / (int64_t)stats->bucket_search_samples;
metrics->bucket_search_stddev_ns = (int64_t)(variance_q48 >> 16);
} else {
metrics->bucket_search_stddev_ns = 0;
}
} else {
metrics->bucket_search_latency_ns = 0;
metrics->bucket_search_stddev_ns = 0;
}
}
/**
* Extract metrics from entire VM
*/
DoeMetrics metrics_from_vm(VM *vm, uint64_t workload_duration_ns,
int32_t cpu_temp_delta_c, int32_t cpu_freq_delta_mhz) {
DoeMetrics metrics = {0};
/* Lookups */
metrics.total_lookups = vm->hotwords_cache ? vm->hotwords_cache->stats.total_lookups : 0;
/* Cache metrics */
if (ENABLE_HOTWORDS_CACHE && vm->hotwords_cache) {
extract_cache_metrics(vm->hotwords_cache, &metrics);
metrics.enable_hotwords_cache = vm->hotwords_cache->enabled ? 1 : 0;
} else {
metrics.enable_hotwords_cache = 0;
}
/* Pipelining metrics - extract from global pipeline metrics (Loop #4) */
metrics.context_predictions_total = vm->pipeline_metrics.prefetch_attempts;
metrics.context_correct = vm->pipeline_metrics.prefetch_hits;
metrics.context_accuracy_percent = 0.0;
if (vm->pipeline_metrics.prefetch_attempts > 0) {
metrics.context_accuracy_percent = 100.0 * (double)vm->pipeline_metrics.prefetch_hits /
(double)vm->pipeline_metrics.prefetch_attempts;
}
/* === Rolling Window Metrics (Loop #2) === */
metrics.window_diversity_percent = 0.0;
metrics.window_final_size_bytes = 4096;
metrics.rolling_window_width = (uint32_t)vm->rolling_window.effective_window_size;
metrics.actual_window_size = (uint32_t)(vm->rolling_window.total_executions < ROLLING_WINDOW_SIZE
? vm->rolling_window.total_executions
: ROLLING_WINDOW_SIZE);
metrics.total_executions = vm->rolling_window.total_executions;
/* Protect access to last_inference_outputs against heartbeat thread race */
sf_mutex_lock(&vm->tuning_lock);
metrics.window_variance_q48 = vm->last_inference_outputs ?
vm->last_inference_outputs->window_variance_q48 : 0;
sf_mutex_unlock(&vm->tuning_lock);
/* === Heat Dynamics (Loop #1 & #3) === */
metrics.decay_slope = (double)vm->decay_slope_q48 / 65536.0;
/* Collect snapshot of current dictionary state */
{
uint64_t hot_word_count = 0;
uint64_t stale_word_count = 0;
uint64_t total_heat = 0;
uint32_t word_count = 0;
sf_mutex_lock(&vm->dict_lock);
for (DictEntry *e = vm->latest; e != NULL; e = e->link) {
if (e->execution_heat > HOTWORDS_EXECUTION_HEAT_THRESHOLD)
hot_word_count++;
else if (e->execution_heat > 0 && e->execution_heat < 10)
stale_word_count++;
total_heat += e->execution_heat;
word_count++;
}
sf_mutex_unlock(&vm->dict_lock);
metrics.total_heat = total_heat;
metrics.hot_word_count = hot_word_count;
metrics.stale_word_count = stale_word_count;
metrics.stale_word_ratio = (word_count > 0) ? (double)stale_word_count / (double)word_count : 0.0;
metrics.avg_word_heat = (word_count > 0) ? (double)total_heat / (double)word_count : 0.0;
}
/* === Heartbeat & Timing (Loop #7) === */
metrics.tick_count = vm->heartbeat.tick_count;
metrics.tick_target_ns = vm->heartbeat.tick_target_ns;
metrics.inference_run_count = vm->heartbeat.inference_run_count;
metrics.early_exit_count = vm->heartbeat.early_exit_count;
/* === Cache Promotions/Demotions (Loop #4) === */
if (vm->hotwords_cache) {
metrics.cache_promotions = vm->hotwords_cache->stats.promotions;
metrics.cache_demotions = vm->hotwords_cache->stats.evictions; /* evictions = demotions */
} else {
metrics.cache_promotions = 0;
metrics.cache_demotions = 0;
}
/* === Window & Decay Inference (Loop #5 & #6) === */
metrics.prefetch_accuracy_percent = 0.0;
metrics.prefetch_attempts = vm->pipeline_metrics.prefetch_attempts;
metrics.prefetch_hits = vm->pipeline_metrics.prefetch_hits;
metrics.window_tuning_checks = vm->pipeline_metrics.window_tuning_checks;
metrics.final_effective_window_size = (uint32_t)vm->rolling_window.effective_window_size;
if (vm->pipeline_metrics.prefetch_attempts > 0) {
metrics.prefetch_accuracy_percent = 100.0 * (double)vm->pipeline_metrics.prefetch_hits /
(double)vm->pipeline_metrics.prefetch_attempts;
}
/* === Performance counters === */
metrics.words_executed = vm->heartbeat.words_executed;
metrics.dictionary_lookups = vm->heartbeat.dictionary_lookups;
/* Performance - workload duration as Q48.16 */
metrics.vm_workload_duration_ns_q48 = (int64_t)workload_duration_ns << 16;
metrics.total_runtime_ms = 0;
metrics.memory_allocated_bytes = 0;
metrics.speedup_vs_baseline = 1.0;
/* Statistical (defaults) */
metrics.ci_lower_95 = 0.0;
metrics.ci_upper_95 = 0.0;
/* System state deltas - convert to Q48.16
* UBSan fix: Use multiplication instead of left-shift for signed values (2025-12-09)
* Left-shifting negative values is undefined behavior */
metrics.cpu_temp_delta_c_q48 = (int64_t)cpu_temp_delta_c * 65536;
metrics.cpu_freq_delta_mhz_q48 = (int64_t)cpu_freq_delta_mhz * 65536;
/* Tuning knobs */
metrics.decay_rate_q16 = DECAY_RATE_PER_US_Q16;
metrics.decay_min_interval_ns = DECAY_MIN_INTERVAL;
metrics.rolling_window_size = ROLLING_WINDOW_SIZE;
metrics.adaptive_shrink_rate = 75;
metrics.heat_cache_demotion_threshold = 10;
/* === Loop Enable Flags (2^7 factorial) === */
/* L8 FINAL INTEGRATION: All loops always-on, controlled by L8 policy */
metrics.enable_loop_1_heat_tracking = 1; /* Always-on (internal signal) */
metrics.enable_loop_2_rolling_window = 1; /* Always-on (L8-controlled) */
metrics.enable_loop_3_linear_decay = 1; /* Always-on */
metrics.enable_loop_4_pipelining = 1; /* Always-on (internal signal) */
metrics.enable_loop_5_window_inference = 1; /* Always-on */
metrics.enable_loop_6_decay_inference = 1; /* Always-on */
metrics.enable_loop_7_adaptive_heartrate = 1; /* Always-on */
/* Legacy configuration */
metrics.enable_hotwords_cache = ENABLE_HOTWORDS_CACHE;
metrics.enable_pipelining = ENABLE_PIPELINING;
return metrics;
}
/**
* Write CSV header
*/
void metrics_write_csv_header(FILE *out) {
fprintf(out,
/* Loop enable flags (2^7 factorial) - FIRST for easy filtering */
"L1_heat,L2_window,L3_decay,L4_pipeline,L5_win_inf,L6_decay_inf,L7_heartrate,"
/* Cache stats */
"total_lookups,cache_hits,cache_hit_pct,bucket_hits,bucket_hit_pct,"
"cache_lat_ns,cache_lat_std,bucket_lat_ns,bucket_lat_std,"
/* Pipelining (Loop #4) */
"ctx_pred_total,ctx_correct,ctx_acc_pct,cache_promos,cache_demos,"
/* Rolling window (Loop #2) */
"win_diversity_pct,win_final_bytes,win_width,actual_win_size,win_total_exec,win_var_q48,"
/* Heat dynamics (Loop #1 & #3) */
"decay_slope,total_heat,hot_words,stale_words,stale_ratio,avg_heat,"
/* Heartbeat & timing (Loop #7) */
"tick_count,tick_target_ns,infer_runs,early_exits,"
/* Window & decay inference (Loop #5 & #6) */
"prefetch_acc_pct,prefetch_attempts,prefetch_hits,win_tune_checks,final_win_size,"
/* Performance */
"workload_ns_q48,runtime_ms,words_exec,dict_lookups,mem_bytes,speedup,"
/* Statistical */
"ci_lower_95,ci_upper_95,"
/* System deltas */
"cpu_temp_delta_q48,cpu_freq_delta_q48,"
/* Tuning knobs */
"decay_rate_q16,decay_min_ns,roll_win_size,shrink_rate,demo_thresh,"
/* Legacy */
"hotwords_cache,pipelining\n");
}
/**
* Write CSV row - MUST match header column order exactly
*/
void metrics_write_csv_row(FILE *out, const DoeMetrics *metrics) {
fprintf(out,
/* Loop enable flags (2^7 factorial) - FIRST for easy filtering */
"%d,%d,%d,%d,%d,%d,%d,"
/* Cache stats */
"%u,%lu,%.2f,%lu,%.2f,"
"%ld,%ld,%ld,%ld,"
/* Pipelining (Loop #4) */
"%lu,%lu,%.2f,%lu,%lu,"
/* Rolling window (Loop #2) */
"%.2f,%u,%u,%u,%lu,%lu,"
/* Heat dynamics (Loop #1 & #3) */
"%.6f,%lu,%lu,%lu,%.6f,%.6f,"
/* Heartbeat & timing (Loop #7) */
"%lu,%lu,%lu,%lu,"
/* Window & decay inference (Loop #5 & #6) */
"%.2f,%lu,%lu,%lu,%u,"
/* Performance */
"%ld,%lu,%lu,%lu,%lu,%.4f,"
/* Statistical */
"%.6f,%.6f,"
/* System deltas */
"%ld,%ld,"
/* Tuning knobs */
"%u,%u,%u,%u,%u,"
/* Legacy */
"%d,%d\n",
/* Loop enable flags */
metrics->enable_loop_1_heat_tracking,
metrics->enable_loop_2_rolling_window,
metrics->enable_loop_3_linear_decay,
metrics->enable_loop_4_pipelining,
metrics->enable_loop_5_window_inference,
metrics->enable_loop_6_decay_inference,
metrics->enable_loop_7_adaptive_heartrate,
/* Cache stats */
metrics->total_lookups,
metrics->cache_hits,
metrics->cache_hit_percent,
metrics->bucket_hits,
metrics->bucket_hit_percent,
metrics->cache_hit_latency_ns,
metrics->cache_hit_stddev_ns,
metrics->bucket_search_latency_ns,
metrics->bucket_search_stddev_ns,
/* Pipelining (Loop #4) */
metrics->context_predictions_total,
metrics->context_correct,
metrics->context_accuracy_percent,
metrics->cache_promotions,
metrics->cache_demotions,
/* Rolling window (Loop #2) */
metrics->window_diversity_percent,
metrics->window_final_size_bytes,
metrics->rolling_window_width,
metrics->actual_window_size,
metrics->total_executions,
metrics->window_variance_q48,
/* Heat dynamics (Loop #1 & #3) */
metrics->decay_slope,
metrics->total_heat,
metrics->hot_word_count,
metrics->stale_word_count,
metrics->stale_word_ratio,
metrics->avg_word_heat,
/* Heartbeat & timing (Loop #7) */
metrics->tick_count,
metrics->tick_target_ns,
metrics->inference_run_count,
metrics->early_exit_count,
/* Window & decay inference (Loop #5 & #6) */
metrics->prefetch_accuracy_percent,
metrics->prefetch_attempts,
metrics->prefetch_hits,
metrics->window_tuning_checks,
metrics->final_effective_window_size,
/* Performance */
metrics->vm_workload_duration_ns_q48,
metrics->total_runtime_ms,
metrics->words_executed,
metrics->dictionary_lookups,
metrics->memory_allocated_bytes,
metrics->speedup_vs_baseline,
/* Statistical */
metrics->ci_lower_95,
metrics->ci_upper_95,
/* System deltas */
metrics->cpu_temp_delta_c_q48,
metrics->cpu_freq_delta_mhz_q48,
/* Tuning knobs */
metrics->decay_rate_q16,
metrics->decay_min_interval_ns,
metrics->rolling_window_size,
metrics->adaptive_shrink_rate,
metrics->heat_cache_demotion_threshold,
/* Legacy */
metrics->enable_hotwords_cache,
metrics->enable_pipelining);
}
/**
* Print metrics as human-readable text
*/
void metrics_print_text(FILE *out, const DoeMetrics *metrics) {
fprintf(out, "\n=== DoE Metrics ===\n");
fprintf(out, "Lookups: %u\n", metrics->total_lookups);
fprintf(out, "Cache Hits: %lu (%.2f%%)\n", metrics->cache_hits, metrics->cache_hit_percent);
fprintf(out, "Bucket Hits: %lu (%.2f%%)\n", metrics->bucket_hits, metrics->bucket_hit_percent);
fprintf(out, "Hit Latency: %ld ns (±%ld)\n", metrics->cache_hit_latency_ns, metrics->cache_hit_stddev_ns);
fprintf(out, "Search Latency: %ld ns (±%ld)\n", metrics->bucket_search_latency_ns, metrics->bucket_search_stddev_ns);
fprintf(out, "Predictions: %lu / %lu (%.2f%% accurate)\n",
metrics->context_correct, metrics->context_predictions_total, metrics->context_accuracy_percent);
fprintf(out, "Window Width: %u bytes\n", metrics->rolling_window_width);
fprintf(out, "Decay Slope: %.2f\n", metrics->decay_slope);
fprintf(out, "Workload Time: %ld ns (Q48.16)\n", metrics->vm_workload_duration_ns_q48);
fprintf(out, "CPU Temp Delta: %ld°C (Q48.16)\n", metrics->cpu_temp_delta_c_q48);
fprintf(out, "CPU Freq Delta: %ld MHz (Q48.16)\n", metrics->cpu_freq_delta_mhz_q48);
}
/**
* Integer square root using Newton's method (pure C99, no math.h)
*/
static uint64_t isqrt(uint64_t n) {
if (n == 0) return 0;
if (n < 4) return 1;
uint64_t x = n;
uint64_t y = (x + 1) / 2;
while (y < x) {
x = y;
y = (x + n / x) / 2;
}
return x;
}
/**
* Write reduced James Law CSV row (20 columns for window scaling experiment)
*
* This outputs only the subset of metrics needed for the James Law validation experiment.
* Format matches the header in run_window_sweep.sh (minus the 5 script-prepended columns).
*
* Expected columns (20):
* workload_duration_ns, l8_mode_final, lambda_effective, K_statistic, K_deviation,
* entropy, cv, temporal_decay, stability_score, ns_per_word, total_runtime_ms,
* window_final, hot_word_count, avg_heat, bucket_mean_K, bucket_cv_K,
* bucket_window_var, bucket_heat_var, bucket_mode_transitions, bucket_collapse_flag
*/
void metrics_write_james_law_csv_row(FILE *out, const DoeMetrics *metrics, VM *vm) {
/* Extract rolling window size for calculations */
uint32_t rolling_window_size = metrics->rolling_window_size;
if (rolling_window_size == 0) rolling_window_size = 1; /* Avoid division by zero */
/* Calculate James Law metrics */
uint32_t window_width = metrics->rolling_window_width;
double lambda_effective = (double)window_width;
double K_statistic = (window_width > 0) ? ((double)window_width / (double)rolling_window_size) : 1.0;
double K_deviation = K_statistic - 1.0;
/* Calculate derived metrics */
double entropy = metrics->window_diversity_percent / 100.0; /* Normalize to 0-1 */
/* Coefficient of variation: use cache hit latency stddev / mean as proxy */
double cv_metric = (metrics->cache_hit_latency_ns > 0)
? ((double)metrics->cache_hit_stddev_ns / (double)metrics->cache_hit_latency_ns)
: 1.0;
double temporal_decay = metrics->decay_slope;
/* Stability score: inverse of stale word ratio (higher = more stable) */
double stability_score = (metrics->stale_word_ratio < 1.0)
? (1.0 - metrics->stale_word_ratio) * 10000.0 /* Scale to match expected range */
: 0.0;
/* Performance: nanoseconds per word executed */
double ns_per_word = (metrics->words_executed > 0)
? ((double)metrics->vm_workload_duration_ns_q48 / (double)metrics->words_executed)
: 0.0;
/* Get L8 mode from VM heartbeat state */
uint8_t l8_mode_final = 1; /* Default to mode 1 if unavailable */
if (vm && vm->heartbeat.tick_buffer_write_index > 0) {
/* Get last tick's L8 mode */
uint32_t last_idx = (vm->heartbeat.tick_buffer_write_index - 1) % HEARTBEAT_TICK_BUFFER_SIZE;
l8_mode_final = vm->heartbeat.tick_buffer[last_idx].l8_mode;
}
/* Calculate bucket aggregates from heartbeat state */
double bucket_mean_K = 0.0;
double bucket_cv_K = 0.0;
double bucket_window_var = 0.0;
double bucket_heat_var = 0.0;
uint32_t bucket_mode_transitions = 0;
int bucket_collapse_flag = 0;
if (vm && vm->heartbeat.bucket_tick_count > 0) {
uint32_t n = vm->heartbeat.bucket_tick_count;
/* Mean K */
bucket_mean_K = vm->heartbeat.bucket_sum_K / (double)n;
/* CV of K: sqrt(variance) / mean using integer approximation */
double mean_K_squared = bucket_mean_K * bucket_mean_K;
double variance_K = (vm->heartbeat.bucket_sum_K_squared / (double)n) - mean_K_squared;
if (variance_K > 0.0 && bucket_mean_K > 0.0) {
/* Scale variance to avoid precision loss, compute integer sqrt, then scale back */
uint64_t variance_scaled = (uint64_t)(variance_K * 1000000.0);
uint64_t stddev_scaled = isqrt(variance_scaled);
double stddev_K = (double)stddev_scaled / 1000.0;
bucket_cv_K = (stddev_K / bucket_mean_K) * 100.0; /* As percentage */
}
/* Window and heat variance (using accumulated sums as proxy) */
bucket_window_var = vm->heartbeat.bucket_sum_window_variance;
bucket_heat_var = vm->heartbeat.bucket_sum_heat_variance;
bucket_mode_transitions = vm->heartbeat.bucket_mode_transitions;
bucket_collapse_flag = vm->heartbeat.bucket_collapse_flag;
}
/* Write CSV row: 20 columns */
fprintf(out,
"%ld,%u,%.6f,%.6f,%.6f," /* workload_duration_ns, l8_mode_final, lambda_effective, K_statistic, K_deviation */
"%.6f,%.6f,%.6f,%.6f,%.6f," /* entropy, cv, temporal_decay, stability_score, ns_per_word */
"%lu,%u,%lu,%.6f," /* total_runtime_ms, window_final, hot_word_count, avg_heat */
"%.6f,%.6f,%.6f,%.6f,%u,%d\n", /* bucket_mean_K, bucket_cv_K, bucket_window_var, bucket_heat_var, bucket_mode_transitions, bucket_collapse_flag */
/* Row 1-5 */
metrics->vm_workload_duration_ns_q48,
l8_mode_final,
lambda_effective,
K_statistic,
K_deviation,
/* Row 6-10 */
entropy,
cv_metric,
temporal_decay,
stability_score,
ns_per_word,
/* Row 11-14 */
metrics->total_runtime_ms,
metrics->final_effective_window_size,
metrics->hot_word_count,
metrics->avg_word_heat,
/* Row 15-20 */
bucket_mean_K,
bucket_cv_K,
bucket_window_var,
bucket_heat_var,
bucket_mode_transitions,
bucket_collapse_flag
);
}
v3/src/heartbeat_export.c
+196
View File
@@ -0,0 +1,196 @@
/*
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 "vm.h"
#include "log.h"
#include "platform_time.h"
#include <stdio.h>
#include <stdlib.h>
/**
* @brief Capture current VM metrics into a heartbeat tick snapshot
*
* Collects 11 metrics per tick for multivariate dynamics analysis.
* Called every heartbeat tick to record VM state.
*
* @param vm Pointer to the VM instance
* @param snapshot Pointer to snapshot structure to populate
*/
void heartbeat_capture_tick_snapshot(VM* vm, HeartbeatTickSnapshot* snapshot)
{
if (!vm || !snapshot)
return;
HeartbeatState* hb = &vm->heartbeat;
/* Monotonic tick counter — use the real heartbeat counter, not tick_count_total */
snapshot->tick_number = (uint32_t)hb->tick_count;
/* Timing: heartbeats ARE the clock ("we count heartbeats not timer ticks").
* sf_monotonic_ns() is unreliable in freestanding kernel (returns 0 on amd64,
* raw counter on riscv64). Use nominal tick period instead. */
snapshot->elapsed_ns = hb->tick_count * (uint64_t)HEARTBEAT_TICK_NS;
static uint64_t last_tick_count = 0;
uint64_t delta_ticks = hb->tick_count - last_tick_count;
snapshot->tick_interval_ns = delta_ticks * (uint64_t)HEARTBEAT_TICK_NS;
last_tick_count = hb->tick_count;
/* Delta metrics — computed from per-VM counters using static last-value tracking.
* On VM reset (current < last), treat current value as the full delta. */
/* Cache metrics from hotwords cache */
snapshot->cache_hits_delta = 0; /* TODO: wire hotwords cache hit counter */
snapshot->bucket_hits_delta = 0; /* TODO: wire bucket hit counter */
/* Word execution delta — words executed since the previous heartbeat tick.
* vm->heartbeat.words_executed is incremented by vm_core.c on every dispatch. */
{
static uint64_t last_words_executed = 0;
uint64_t cur = hb->words_executed;
snapshot->word_executions_delta = (uint32_t)(cur >= last_words_executed
? cur - last_words_executed
: cur);
last_words_executed = cur;
}
/* Hot word count - walk dictionary and count words above threshold */
snapshot->hot_word_count = 0;
uint64_t total_heat = 0;
uint32_t word_count = 0;
for (DictEntry* entry = vm->latest; entry; entry = entry->link)
{
if (entry->execution_heat > 0)
{
total_heat += entry->execution_heat;
word_count++;
/* Count as "hot" if above cache promotion threshold */
if (entry->execution_heat >= 10) /* HEAT_CACHE_DEMOTION_THRESHOLD */
{
snapshot->hot_word_count++;
}
}
}
/* Average word heat (convert Q48.16 to double) */
if (word_count > 0)
{
snapshot->avg_word_heat = (double)total_heat / (double)word_count / 65536.0;
}
else
{
snapshot->avg_word_heat = 0.0;
}
/* Rolling window size.
* window_width = L8's inferred effective size (the target).
* actual_window_size = min(total_executions, effective_window_size):
* how many entries are ACTUALLY being analysed right now — grows toward
* window_width as data accumulates, then tracks it as L8 narrows/widens. */
snapshot->window_width = vm->rolling_window.effective_window_size;
{
uint64_t fill = vm->rolling_window.total_executions;
uint32_t eff = vm->rolling_window.effective_window_size;
snapshot->actual_window_size = (uint32_t)(fill < (uint64_t)eff ? fill : eff);
}
/* predicted_label_hits: ANOVA early-exit confirmations per tick.
* Each early exit means the inference engine validated the current L8 config
* as stable — the selector's choice correlated with subsequent execution patterns.
* High rate = selector chose well and the system settled.
* Low rate = selector is still searching. */
{
static uint64_t last_early_exit_count = 0;
uint64_t cur = hb->early_exit_count;
snapshot->predicted_label_hits = (uint32_t)(cur >= last_early_exit_count
? cur - last_early_exit_count
: cur);
last_early_exit_count = cur;
}
/* Jitter: tick-based timing has no wall-clock deviation to measure.
* Encode delta_ticks as a deviation: 0 means exactly on schedule (1 tick/call). */
snapshot->estimated_jitter_ns = (delta_ticks > 1)
? (double)((delta_ticks - 1) * (uint64_t)HEARTBEAT_TICK_NS)
: 0.0;
}
/**
* @brief Emit a heartbeat tick snapshot as CSV row to stderr
*
* Outputs 11 comma-separated values (no header) for real-time streaming.
* Called every heartbeat tick to emit metrics immediately.
*
* Format: tick_number,elapsed_ns,tick_interval_ns,cache_hits_delta,
* bucket_hits_delta,word_executions_delta,hot_word_count,
* avg_word_heat,window_width,actual_window_size,predicted_label_hits,estimated_jitter_ns
*
* @param vm Pointer to the VM instance (unused, for API consistency)
* @param snapshot Pointer to the snapshot to emit
*/
void heartbeat_emit_tick_row(VM* vm, HeartbeatTickSnapshot* snapshot)
{
(void)vm; /* Unused parameter */
if (!snapshot)
return;
/* Emit CSV row to stderr - no header, just data */
fprintf(stderr, "%u,%lu,%lu,%u,%u,%u,%lu,%.6f,%u,%u,%u,%.2f\n",
snapshot->tick_number,
snapshot->elapsed_ns,
snapshot->tick_interval_ns,
snapshot->cache_hits_delta,
snapshot->bucket_hits_delta,
snapshot->word_executions_delta,
snapshot->hot_word_count,
snapshot->avg_word_heat,
snapshot->window_width,
snapshot->actual_window_size,
snapshot->predicted_label_hits,
snapshot->estimated_jitter_ns);
/* Ensure immediate output to stderr (unbuffered) */
fflush(stderr);
}
v3/src/inference_engine.c
+832
View File
@@ -0,0 +1,832 @@
/*
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 <stdlib.h>
#include <string.h>
#include <stdio.h>
#include <stdint.h>
#include <assert.h>
#include "inference_engine.h"
#include "q48_16.h"
#include "vm.h"
#include "rolling_window_of_truth.h"
#include "ssm_jacquard.h"
/* ============================================================================
* Phase 2A: ANOVA Early-Exit Check
* ============================================================================
*
* Purpose: Skip full inference if variance hasn't changed significantly
* Threshold: 5% variance change (VARIANCE_SIGNIFICANCE_THRESHOLD in vm.h)
* Cost if stable: ~100 CPU cycles
* Cost if unstable: Full inference run (~5-10k cycles)
*/
/**
* @brief ANOVA early-exit check: test whether variance has stabilised.
*
* Computes |current - last| / last. If the relative change is <= 5%
* (threshold = 3276 in Q48.16), the variance is considered stable and
* full inference can be skipped (~100 cycles vs ~5–10k for a full run).
* Always returns 0 (unstable) on the first call when @c last_variance == 0.
*
* @param current_variance Variance from the current snapshot (Q48.16)
* @param last_variance Variance from the previous inference run (Q48.16)
* @return 1 if variance is stable (skip inference), 0 if full run needed
*/
static int has_variance_stabilized(
q48_16_t current_variance,
q48_16_t last_variance
)
{
if (last_variance == 0) {
/* First run, always do full inference */
return 0;
}
/* Calculate variance delta as ratio */
q48_16_t delta = (current_variance > last_variance)
? (current_variance - last_variance)
: (last_variance - current_variance);
/* Compute delta / last_variance in Q48.16 */
q48_16_t ratio = q48_div(delta, last_variance);
/* Threshold: 5% = 0.05 in Q48.16 = 0.05 * 65536 = 3276 */
q48_16_t threshold = 3276;
if (ratio <= threshold) {
/* Variance is stable, skip full inference */
return 1;
}
/* Variance changed significantly, run full inference */
return 0;
}
/* ============================================================================
* Phase 2B: Heat Trajectory Extraction
* ============================================================================
*
* Purpose: Fresh snapshot of execution_heat from dictionary
* Strategy: Iterate vm->latest backwards, collect heat values
* Timing: O(dictionary_entries), called every HEARTBEAT_INFERENCE_FREQUENCY ticks
*/
/*
* Build a heat trajectory for inference using a consistent rolling window snapshot.
*
* We linearize the rolling window into a temporary ID buffer (via the public export API)
* and convert the most recent entries into execution_heat samples by consulting the
* stable word-id map protected by dict_lock. This keeps the inference engine fully
* thread-safe while still operating on real heat values instead of raw IDs.
*/
/**
* @brief Build a heat trajectory array from the rolling window of truth.
*
* Linearises the rolling window via @c rolling_window_export_execution_history(),
* then translates each word-id slot to its current @c execution_heat by
* looking up the entry under @c vm->dict_lock. The result is a freshly
* allocated array of @c *out_length uint64_t values in chronological order.
* The caller is responsible for freeing the returned pointer. Returns NULL
* (and sets @c *out_length = 0) on allocation failure or empty window.
*
* @param window Rolling window to export from
* @param vm VM whose dictionary is consulted for heat values
* @param out_length Output: number of elements in the returned array
* @return Heap-allocated trajectory array, or NULL on failure
*/
static uint64_t* extract_heat_trajectory(
RollingWindowOfTruth *window,
VM *vm,
uint64_t *out_length
)
{
if (!window || !vm || !out_length) {
return NULL;
}
uint32_t *word_ids = (uint32_t*)malloc(ROLLING_WINDOW_SIZE * sizeof(uint32_t));
if (!word_ids) {
*out_length = 0;
return NULL;
}
uint64_t exported = rolling_window_export_execution_history(window,
word_ids,
ROLLING_WINDOW_SIZE);
if (exported == 0) {
free(word_ids);
*out_length = 0;
return NULL;
}
uint64_t span = window->is_warm
? (uint64_t)window->effective_window_size
: exported;
if (span > exported) span = exported;
if (span == 0) {
free(word_ids);
*out_length = 0;
return NULL;
}
uint64_t *trajectory = (uint64_t*)malloc(span * sizeof(uint64_t));
if (!trajectory) {
free(word_ids);
*out_length = 0;
return NULL;
}
uint64_t start = exported - span;
sf_mutex_lock(&vm->dict_lock);
for (uint64_t i = 0; i < span; i++) {
uint32_t word_id = word_ids[start + i];
uint64_t heat = 0;
if (word_id < DICTIONARY_SIZE) {
DictEntry *entry = vm_dictionary_lookup_by_word_id(vm, word_id);
if (entry) {
heat = (uint64_t)entry->execution_heat;
}
}
trajectory[i] = heat;
}
sf_mutex_unlock(&vm->dict_lock);
free(word_ids);
*out_length = span;
return trajectory;
}
/* ============================================================================
* Phase 2C: Window Width Inference (Variance Inflection)
* ============================================================================
*
* Purpose: Find statistical point where adding more data stops refining understanding
*
* Algorithm:
* 1. For each sub-window size from MIN to full:
* - Compute variance_q48 of heat in that window
* 2. Detect inflection: where d(variance)/d(size) → 0
* - When |variance[i+1] - variance[i]| < 1% of current variance
* - Return that size as inferred_window_width
* 3. Clamp to [ADAPTIVE_MIN_WINDOW_SIZE, ROLLING_WINDOW_SIZE]
*/
/**
* @brief Compute the variance of a heat trajectory in Q48.16 fixed-point.
*
* Computes the population variance: Σ(heat[i] - mean)² / N.
* All intermediate calculations use Q48.16 arithmetic. Returns 0 for
* an empty array.
*
* @param heat_data Array of execution heat values (raw uint64_t counts)
* @param length Number of elements in @c heat_data
* @return Population variance in Q48.16 format
*/
q48_16_t compute_variance_q48(
const uint64_t *heat_data,
uint64_t length
)
{
if (length == 0) return 0;
/* Compute mean in Q48.16 */
uint64_t sum = 0;
for (uint64_t i = 0; i < length; i++) {
sum += heat_data[i];
}
q48_16_t mean = q48_div(q48_from_u64(sum), q48_from_u64(length));
/* Compute sum of squared deviations */
uint64_t sum_sq_diff = 0;
for (uint64_t i = 0; i < length; i++) {
q48_16_t heat_q48 = q48_from_u64(heat_data[i]);
q48_16_t diff = (heat_q48 > mean) ? (heat_q48 - mean) : (mean - heat_q48);
q48_16_t sq_diff = q48_mul(diff, diff);
sum_sq_diff += q48_to_u64(sq_diff);
}
/* Variance = sum_sq_diff / length */
q48_16_t variance = q48_div(q48_from_u64(sum_sq_diff), q48_from_u64(length));
return variance;
}
/* ============================================================================
* Helper: Compute Median (for Levene's Test)
* ============================================================================
*
* Purpose: Find median of array for robust central tendency
* Note: Uses simple selection algorithm (O(n) expected, O(n²) worst case)
*/
/**
* @brief Compute the median of a Q48.16 array.
*
* Makes a temporary copy, sorts it with bubble sort (acceptable for the
* small chunk counts used in Levene's test, typically K <= 16), and
* returns the middle element. Returns 0 for an empty array.
*
* @param data Array of Q48.16 values
* @param length Number of elements
* @return Median value in Q48.16 format
*/
static q48_16_t compute_median_q48(
const q48_16_t *data,
uint32_t length
)
{
if (length == 0) return 0;
if (length == 1) return data[0];
/* Make a copy and sort (bubble sort for small arrays) */
q48_16_t *sorted = (q48_16_t *)malloc(length * sizeof(q48_16_t));
if (!sorted) return 0;
memcpy(sorted, data, length * sizeof(q48_16_t));
/* Simple bubble sort */
for (uint32_t i = 0; i < length - 1; i++) {
for (uint32_t j = 0; j < length - i - 1; j++) {
if (sorted[j] > sorted[j + 1]) {
q48_16_t tmp = sorted[j];
sorted[j] = sorted[j + 1];
sorted[j + 1] = tmp;
}
}
}
q48_16_t median = sorted[length / 2];
free(sorted);
return median;
}
/* ============================================================================
* Helper: Compute Mean in Q48.16
* ============================================================================
*
* Purpose: Calculate arithmetic mean of Q48.16 values
*/
/**
* @brief Compute the arithmetic mean of a Q48.16 array.
*
* Sums the integer parts of each element (>> 16) and returns the result
* converted back to Q48.16. Returns 0 for an empty array.
*
* @param data Array of Q48.16 values
* @param length Number of elements
* @return Arithmetic mean in Q48.16 format
*/
static q48_16_t compute_mean_q48(
const q48_16_t *data,
uint32_t length
)
{
if (length == 0) return 0;
uint64_t sum = 0;
for (uint32_t i = 0; i < length; i++) {
sum += data[i] >> 16; /* Convert to integer part */
}
return q48_from_u64(sum / length);
}
/* ============================================================================
* Levene's Test for Equality of Variance (Statistically Valid)
* ============================================================================
*
* Purpose: Test if multiple samples have equal variance
* Reference: Levene, H. (1960). "Robust tests for equality of variances"
*
* Null Hypothesis H₀: All chunk variances are equal
* Test Statistic W: Ratio of variance of deviations to overall deviation
*
* If W > critical_value (≈6.5 for α=0.05): REJECT H₀ (variances differ)
* If W ≤ critical_value: FAIL TO REJECT H₀ (variances are similar)
*
* Input:
* - chunk_variances: Array of K variance values (one per chunk)
* - num_chunks: K (number of chunks)
* - chunk_size: N (size of each chunk, all equal)
*
* Output:
* - W statistic in Q48.16 format
* - Compare result to LEVENE_CRITICAL_VALUE_Q48
*/
/**
* @brief Compute Levene's W statistic for equality of variance.
*
* Tests the null hypothesis H₀: all chunk variances are equal.
* Uses the median-based variant for robustness: z_i = |var_i - median_var|,
* then W = (K-1)*N*Σ(z_i - z_bar)² / (K*N * var(z)).
* Returns 0 for fewer than 2 chunks. Compare result to
* @c LEVENE_CRITICAL_VALUE_Q48 (≈ 6.5 at α=0.05): W > critical means
* variances differ significantly.
*
* @param chunk_variances Array of K per-chunk variance values (Q48.16)
* @param num_chunks Number of chunks K (must be >= 2)
* @param chunk_size Number of samples N per chunk
* @return Levene's W statistic in Q48.16 format
*/
static q48_16_t compute_levene_statistic(
const q48_16_t *chunk_variances,
uint32_t num_chunks,
uint32_t chunk_size
)
{
if (num_chunks < 2) return 0;
/* Step 1: Compute median variance */
q48_16_t median_var = compute_median_q48(chunk_variances, num_chunks);
/* Step 2: Compute z_i = |variance_i - median_var| */
q48_16_t *z = (q48_16_t *)malloc(num_chunks * sizeof(q48_16_t));
if (!z) return 0;
for (uint32_t i = 0; i < num_chunks; i++) {
z[i] = (chunk_variances[i] > median_var)
? (chunk_variances[i] - median_var)
: (median_var - chunk_variances[i]);
}
/* Step 3: Compute z_bar = mean(z) */
q48_16_t z_bar = compute_mean_q48(z, num_chunks);
/* Step 4: Compute numerator = (K-1) * N * Σ(z_i - z_bar)² */
q48_16_t sum_sq_diff = 0;
for (uint32_t i = 0; i < num_chunks; i++) {
q48_16_t diff = (z[i] > z_bar) ? (z[i] - z_bar) : (z_bar - z[i]);
q48_16_t sq = q48_mul(diff, diff);
sum_sq_diff = q48_add(sum_sq_diff, sq);
}
q48_16_t numerator = q48_mul(
q48_from_u64(num_chunks - 1),
q48_mul(q48_from_u64(chunk_size), sum_sq_diff)
);
/* Step 5: Compute denominator = Σ_i Σ_j (z_ij - z_i_mean)² */
/* Approximation: Use variance of z values */
q48_16_t z_variance = compute_variance_q48((const uint64_t *)z, num_chunks);
q48_16_t denominator = q48_mul(q48_from_u64(num_chunks), z_variance);
/* Step 6: W = numerator / denominator */
q48_16_t W = (denominator > 0) ? q48_div(numerator, denominator) : 0;
free(z);
return W;
}
/**
* @brief Find the minimum window size where heat variance is statistically stable.
*
* Implements Loop #5 (window width inference). Scans candidate window sizes from
* @c ADAPTIVE_MIN_WINDOW_SIZE to the full trajectory in steps of 64, divides the
* trajectory into disjoint chunks of that size, and applies Levene's test. Returns
* the first size where W <= 6.5 (α=0.05 critical value). Falls back to the full
* trajectory length if no size passes. @c full_variance is unused (retained for
* API compatibility with callers that pre-compute it).
*
* @param heat_data Heat trajectory array
* @param trajectory_length Number of elements in @c heat_data
* @param full_variance Unused; retained for API compatibility
* @return Minimum sufficient window width in [ADAPTIVE_MIN_WINDOW_SIZE, ROLLING_WINDOW_SIZE]
*/
uint32_t find_variance_inflection(
const uint64_t *heat_data,
uint64_t trajectory_length,
q48_16_t full_variance /* Unused in new algorithm */
)
{
(void)full_variance;
/* ========================================================================
* REDESIGNED: Levene's Test for Statistical Validity (2025-11-19)
* ========================================================================
*
* OLD ALGORITHM (FLAWED):
* - Computed prefix variance: var[0..N], var[0..2N], var[0..3N], ...
* - Violated statistical independence
* - Confounded "enough data" with "variance decay"
* - Used magic 1% threshold with no statistical justification
*
* NEW ALGORITHM (VALID):
* - Divides trajectory into K disjoint chunks of size N
* - Computes variance of each chunk independently
* - Uses Levene's test for equality of variance
* - Statistically sound hypothesis test (α=0.05)
* - Finds MINIMUM window size where variance is stable
*
* Reference: Levene, H. (1960). "Robust tests for equality of variances"
* In: Contributions to Probability and Statistics
*/
/* Use constants from vm.h (defined as macros) */
#ifndef ADAPTIVE_MIN_WINDOW_SIZE
#define ADAPTIVE_MIN_WINDOW_SIZE 256
#endif
#ifndef ROLLING_WINDOW_SIZE
#define ROLLING_WINDOW_SIZE 4096
#endif
if (trajectory_length == 0) {
return ROLLING_WINDOW_SIZE / 2; /* Default */
}
uint32_t min_size = ADAPTIVE_MIN_WINDOW_SIZE;
uint32_t max_size = (trajectory_length < ROLLING_WINDOW_SIZE)
? (uint32_t)trajectory_length
: ROLLING_WINDOW_SIZE;
/* Levene's critical value for α=0.05 with K≥3 degrees of freedom */
/* Theoretical value ≈ 5.88, conservative estimate ≈ 6.5 */
q48_16_t levene_critical = q48_from_double(6.5);
/* Scan for minimum window size where variance is statistically stable */
for (uint32_t size = min_size; size <= max_size; size += 64) {
uint32_t num_chunks = (uint32_t)(trajectory_length / size);
/* Need at least 3 chunks for reliable statistical test */
if (num_chunks < 3) {
continue; /* Too few chunks, try larger size */
}
/* Allocate and compute variance for each disjoint chunk */
q48_16_t *chunk_vars = (q48_16_t *)malloc(num_chunks * sizeof(q48_16_t));
if (!chunk_vars) {
continue; /* Allocation failed, skip this size */
}
for (uint32_t i = 0; i < num_chunks; i++) {
uint64_t chunk_start = (uint64_t)i * (uint64_t)size;
chunk_vars[i] = compute_variance_q48(
&heat_data[chunk_start],
size
);
}
/* Apply Levene's test for equality of variance */
q48_16_t W = compute_levene_statistic(chunk_vars, num_chunks, size);
free(chunk_vars);
/* If test passes: variances are statistically similar */
/* This window size is SUFFICIENT for capturing the pattern */
if (W <= levene_critical) {
return size; /* Found minimum sufficient window */
}
}
/* If no size passed test, use maximum available */
return max_size;
}
/* ============================================================================
* Phase 2D: Decay Slope Inference (Closed-Form Linear Regression)
* ============================================================================
*
* Purpose: Extract decay_slope from heat trajectory via exponential fitting
*
* Model: ln(heat[t]) = ln(h0) - slope*t
* (Exponential decay: heat(t) = h0 * e^(-slope*t))
*
* Algorithm (Integer-only, Q48.16):
* 1. Transform trajectory to log space
* 2. Linear regression on log_heat = a - slope*t
* 3. Extract slope coefficient
*
* Closed-form solution:
* numerator = n * Σ(t*ln(heat)) - Σt * Σln(heat)
* denominator = n * Σ(t²) - (Σt)²
* slope = numerator / denominator
*/
/**
* @brief Infer the decay slope from a heat trajectory via log-linear regression.
*
* Implements Loop #6 (decay slope inference). Fits the model
* ln(heat[t]) = ln(h₀) - slope*t using the closed-form OLS solution:
* slope = (n*Σ(t·ln(h)) - Σt·Σln(h)) / (n·Σt² - (Σt)²).
* The sign of the numerator is taken as absolute value since decay rate
* is always positive. Zero heat values are skipped. Returns 0 if fewer
* than 2 samples are available.
*
* @param heat_data Array of execution heat values (raw counts)
* @param length Number of elements in @c heat_data
* @return Inferred decay slope in Q48.16 format (0 = insufficient data)
*/
uint64_t infer_decay_slope_q48(
const uint64_t *heat_data,
uint64_t length
)
{
if (length < 2) {
return 0;
}
/* Compute sums for linear regression */
uint64_t n = length;
uint64_t sum_t = (n * (n - 1)) / 2; /* 0+1+2+...+(n-1) */
uint64_t sum_t_sq = (n * (n - 1) * (2 * n - 1)) / 6; /* 0²+1²+...+(n-1)² */
q48_16_t sum_log_heat = 0;
q48_16_t sum_t_log_heat = 0;
for (uint64_t t = 0; t < length; t++) {
if (heat_data[t] == 0) continue; /* Skip zero heat values */
/* Compute ln(heat[t]) in Q48.16 */
q48_16_t log_heat = q48_log_approx(heat_data[t]);
sum_log_heat = q48_add(sum_log_heat, log_heat);
/* Compute t * ln(heat[t]) */
q48_16_t t_log = q48_mul(q48_from_u64(t), log_heat);
sum_t_log_heat = q48_add(sum_t_log_heat, t_log);
}
/* Compute slope = (n*Σ(t*ln) - Σt*Σln) / (n*Σ(t²) - (Σt)²) */
/* Note: For decay, numerator may be negative, so use signed arithmetic */
int64_t n_times_sum_t_log = (int64_t)q48_mul(q48_from_u64(n), sum_t_log_heat);
int64_t sum_t_times_sum_log = (int64_t)q48_mul(q48_from_u64(sum_t), sum_log_heat);
int64_t numerator_signed = n_times_sum_t_log - sum_t_times_sum_log;
/* Take absolute value (decay rate is always positive) */
uint64_t numerator = (numerator_signed < 0) ? (uint64_t)(-numerator_signed) : (uint64_t)numerator_signed;
uint64_t denominator_raw = (n * sum_t_sq) - (sum_t * sum_t);
if (denominator_raw == 0) {
denominator_raw = 1; /* Avoid division by zero */
}
/* Divide: numerator is Q48.16, denominator is raw */
/* slope = numerator_Q48 / denominator_raw preserves Q48.16 scaling */
uint64_t slope = numerator / denominator_raw;
return slope;
}
/* ============================================================================
* Phase 2E: Fit Quality Assessment
* ============================================================================
*
* Purpose: Compute R² or residual metric for diagnostics
* Simplified: Use residual sum of squares / total sum of squares
*/
/**
* @brief Compute R²-style fit quality for the inferred decay slope.
*
* Currently returns a fixed placeholder of 0.8 in Q48.16 (52429). A full
* residual-sum-of-squares implementation is planned but deferred — the
* placeholder is sufficient for the DoE convergence signal.
*
* @param heat_data Array of heat values (unused in current implementation)
* @param length Array length (unused in current implementation)
* @param slope_q48 Inferred slope in Q48.16 (unused in current implementation)
* @return Fit quality in Q48.16; currently always 0.8 (52429)
*/
static uint64_t compute_fit_quality(
const uint64_t *heat_data,
uint64_t length,
uint64_t slope_q48
)
{
(void)heat_data;
(void)slope_q48;
if (length < 2) {
return q48_from_u64(1); /* Perfect fit if no data */
}
/* Simplified: Return ratio of predicted-to-actual variance */
/* For now: return 0.8 in Q48.16 as placeholder */
return (q48_16_t)52429ULL; /* 0.8 * 65536 ≈ 52429 in Q48.16 */
}
/* ============================================================================
* Main API: inference_engine_run()
* ============================================================================
*
* High-level orchestrator that coordinates all inference phases
*/
/*
* @brief Run the full inference engine pipeline.
*
* High-level orchestrator for Loops #5 and #6. In order:
* 1. Extract the heat trajectory from the rolling window (Phase 2B).
* 2. ANOVA early-exit check — if variance is stable, skip and set
* @c outputs->early_exited = 1 (Phase 2A).
* 3. Window width inference via Levene's test — gated by L5 flag in
* @c vm->ssm_config (Phase 2C).
* 4. Decay slope inference via log-linear regression — gated by L6 flag
* (Phase 2D).
* 5. Fit quality assessment (Phase 2E).
* Writes all results into @c outputs and frees the trajectory. No-op if
* any required pointer is NULL.
*
* @param inputs Input pointers: rolling window and VM reference
* @param outputs Output struct updated with window, slope, variance, fit quality
*/
void inference_engine_run(InferenceInputs *inputs, InferenceOutputs *outputs)
{
if (!inputs || !outputs || !inputs->window || !inputs->vm) {
return;
}
/* === PHASE 2B: Extract Fresh Heat Trajectory === */
uint64_t traj_len = 0;
uint64_t *trajectory = extract_heat_trajectory(inputs->window, inputs->vm, &traj_len);
if (!trajectory || traj_len < 2) {
outputs->early_exited = 1;
if (trajectory) free(trajectory);
return;
}
/* === PHASE 2A: ANOVA Early-Exit Check (using actual heat samples) === */
q48_16_t current_variance = compute_variance_q48(trajectory, traj_len);
if (has_variance_stabilized(current_variance, outputs->window_variance_q48)) {
outputs->early_exited = 1;
free(trajectory);
return;
}
/* === PHASE 2C: Window Width Inference === */
/* L8 FINAL INTEGRATION: Loop #5 runtime-gated by Jacquard mode selector */
uint32_t inferred_width = outputs->adaptive_window_width; /* Keep previous value as default */
if (inputs->vm && inputs->vm->ssm_config) {
ssm_config_t *config = (ssm_config_t*)inputs->vm->ssm_config;
if (config->L5_window_inference) {
/* L5 enabled - run inference */
inferred_width = find_variance_inflection(
trajectory,
traj_len,
current_variance
);
}
/* else: L5 disabled, keep previous adaptive_window_width */
} else {
/* No L8 config available - run inference (legacy mode) */
inferred_width = find_variance_inflection(
trajectory,
traj_len,
current_variance
);
}
/* === PHASE 2D: Decay Slope Inference === */
/* L8 FINAL INTEGRATION: Loop #6 runtime-gated by Jacquard mode selector */
uint64_t inferred_slope = outputs->adaptive_decay_slope; /* Keep previous value as default */
if (inputs->vm && inputs->vm->ssm_config) {
ssm_config_t *config = (ssm_config_t*)inputs->vm->ssm_config;
if (config->L6_decay_inference) {
/* L6 enabled - run inference */
inferred_slope = infer_decay_slope_q48(trajectory, traj_len);
}
/* else: L6 disabled, keep previous adaptive_decay_slope */
} else {
/* No L8 config available - run inference (legacy mode) */
inferred_slope = infer_decay_slope_q48(trajectory, traj_len);
}
/* === PHASE 2E: Diagnostics === */
uint64_t fit_quality = compute_fit_quality(trajectory, traj_len, inferred_slope);
/* === Update Outputs === */
outputs->adaptive_window_width = inferred_width;
outputs->adaptive_decay_slope = inferred_slope;
outputs->window_variance_q48 = current_variance;
outputs->slope_fit_quality_q48 = fit_quality;
outputs->early_exited = 0;
/* === Cleanup === */
free(trajectory);
}
/* ============================================================================
* Helper Functions: Logging & Validation
* ============================================================================
*/
/**
* @brief Format inference outputs as a human-readable string.
*
* Writes into a static 256-byte buffer — not thread-safe, for diagnostics only.
* Format: @c "window=N var=F slope=F quality=F (cached|full)".
*
* @param outputs Inference outputs to format (NULL produces @c "(null)")
* @return Pointer to a static string buffer
*/
const char* inference_outputs_to_string(const InferenceOutputs *outputs)
{
static char buf[256];
if (!outputs) {
snprintf(buf, sizeof(buf), "(null)");
return buf;
}
double var_dbl = q48_to_double(outputs->window_variance_q48);
double slope_dbl = q48_to_double(outputs->adaptive_decay_slope);
double quality_dbl = q48_to_double(outputs->slope_fit_quality_q48);
snprintf(buf, sizeof(buf),
"window=%u var=%.6f slope=%.6f quality=%.6f %s",
outputs->adaptive_window_width,
var_dbl,
slope_dbl,
quality_dbl,
outputs->early_exited ? "(cached)" : "(full)");
return buf;
}
/**
* @brief Validate inference outputs for sanity.
*
* Checks that @c adaptive_window_width is in
* [@c ADAPTIVE_MIN_WINDOW_SIZE, @c ROLLING_WINDOW_SIZE], that
* @c adaptive_decay_slope is non-zero and <= 100.0 in Q48.16, and that
* @c slope_fit_quality_q48 is in [0.0, 1.0].
*
* @param outputs Inference outputs to validate (NULL returns 0)
* @return 1 if all fields are within acceptable ranges, 0 otherwise
*/
int inference_outputs_validate(const InferenceOutputs *outputs)
{
if (!outputs) {
return 0;
}
/* Check window width is reasonable */
#ifndef ADAPTIVE_MIN_WINDOW_SIZE
#define ADAPTIVE_MIN_WINDOW_SIZE 256
#endif
#ifndef ROLLING_WINDOW_SIZE
#define ROLLING_WINDOW_SIZE 4096
#endif
if (outputs->adaptive_window_width < ADAPTIVE_MIN_WINDOW_SIZE ||
outputs->adaptive_window_width > ROLLING_WINDOW_SIZE) {
return 0;
}
/* Check slope is positive and reasonable */
/* Typical range: 0.001 to 100.0 in Q48.16 */
if (outputs->adaptive_decay_slope == 0 ||
outputs->adaptive_decay_slope > q48_from_u64(100)) {
return 0;
}
/* Check fit quality is between 0.0 and 1.0 */
if (outputs->slope_fit_quality_q48 > q48_from_u64(1)) {
return 0;
}
return 1;
}
v3/src/io.c
+104
View File
@@ -0,0 +1,104 @@
/*
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 "io.h"
#include "log.h"
#include <string.h>
/** @} */
/**
* @brief Initialize the IO subsystem
* @param vm Pointer to VM instance
*
* Initializes the block device view over the unified VM memory.
* Zeros out the entire VM memory space.
*/
void io_init(VM *vm) {
if (!vm || !vm->memory) {
log_message(LOG_ERROR, "io_init: VM or VM memory not initialized");
return;
}
/* Zero the entire VM address space so blocks start clean. */
memset(vm->memory, 0, VM_MEMORY_SIZE);
log_message(LOG_INFO,
"IO subsystem initialized with %d blocks of %d bytes",
(int) MAX_BLOCKS, (int) BLOCK_SIZE);
}
/*
* @brief Write a block to VM memory
* @param vm Pointer to VM instance
* @param block_num Block number to write (0 to MAX_BLOCKS-1)
* @param buffer Source buffer containing block data
* @return 0 on success, -1 on error
*/
/**
* @brief Write a block to VM memory
* @param vm Pointer to VM instance
* @param block_num Block number to write (0 to MAX_BLOCKS-1)
* @param buffer Source buffer containing block data
* @return 0 on success, -1 on error
*
* Writes a BLOCK_SIZE chunk of data from the provided buffer into the VM's memory
* at the specified block number offset. The block number must be within valid range.
* The entire block is written atomically.
*
* @note The buffer must contain at least BLOCK_SIZE bytes of valid data
*/
int io_write_block(VM *vm, int block_num, const unsigned char *buffer) {
if (!vm || !vm->memory || !buffer) {
log_message(LOG_ERROR, "io_write_block: bad args");
return -1;
}
if (block_num < 0 || block_num >= (int) MAX_BLOCKS) {
log_message(LOG_ERROR, "io_write_block: invalid block number %d", block_num);
return -1;
}
size_t off = (size_t) block_num * (size_t) BLOCK_SIZE;
memcpy(&vm->memory[off], buffer, BLOCK_SIZE);
log_message(LOG_DEBUG, "io_write_block: wrote block %d", block_num);
return 0;
}
v3/src/log.c
+198
View File
@@ -0,0 +1,198 @@
/*
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/log.h"
#include "../include/platform_time.h"
#include <stdio.h>
#include <stdarg.h>
#include <time.h>
/* Current log level (default to LOG_INFO) */
static LogLevel current_level = LOG_INFO;
/* Log level names */
static const char *level_names[] = {
"ERROR",
"WARN",
"INFO",
"TEST",
"DEBUG"
};
/* ANSI color codes for each log level - only used outside minimal mode;
* MINIMAL builds never read these (both use sites are #ifndef-guarded
* below), so no empty-string fallback definitions are needed. */
#ifndef STARFORTH_MINIMAL
static const char *level_colors[] = {
"\x1b[31m", // ERROR - Red
"\x1b[33m", // WARN - Yellow
"\x1b[32m", // INFO - Green
"\x1b[35m", // TEST - Magenta
"\x1b[34m" // DEBUG - Blue
};
/* Test result colors */
static const char *test_pass_color = "\x1b[32m"; // Green
static const char *test_fail_color = "\x1b[31m"; // Red
static const char *test_skip_color = "\x1b[33m"; // Yellow
/* Reset color */
static const char *color_reset = "\x1b[0m";
#endif
/* Set global log level */
/*
* @brief Sets the global logging level
*
* @param level The LogLevel to set as current logging level
*/
void log_set_level(LogLevel level) {
current_level = level;
}
/* Get current log level */
/**
* @brief Gets the current global logging level
*
* @return LogLevel Current logging level
*/
LogLevel log_get_level(void) {
return current_level;
}
/* Timestamp helper */
/**
* @brief Helper function to generate timestamp string
*
* @param buffer Output buffer for the timestamp string
* @param size Size of the output buffer
*/
static void get_timestamp(char *buffer, size_t size) {
/* Use platform abstraction for timestamps */
sf_time_ns_t now = sf_realtime_ns();
sf_format_timestamp(now, buffer, 1); /* 24-hour format */
}
/* Generic logger */
/*
* @brief Logs a message with the specified level and format
*
* @param level The LogLevel for this message
* @param fmt Printf-style format string
* @param ... Variable arguments for format string
*/
void log_message(LogLevel level, const char *fmt, ...) {
/* LOG_NONE (-1) disables ALL logging */
if (current_level == LOG_NONE || level > current_level)
return;
char timestamp[16];
get_timestamp(timestamp, sizeof(timestamp));
#ifndef STARFORTH_MINIMAL
fprintf(stderr, "%s[%s] %s: %s", level_colors[level], timestamp, level_names[level], color_reset);
#else
fprintf(stderr, "[%s] %s: ", timestamp, level_names[level]);
#endif
va_list args;
va_start(args, fmt);
vfprintf(stderr, fmt, args);
va_end(args);
fprintf(stderr, "\n");
}
/* Dedicated test result logger (only shown for LOG_TEST or higher) */
/*
* @brief Logs test results_run_01_2025_12_08 with appropriate formatting and colors
*
* @param word_name Name of the word being tested
* @param result Test result (PASS/FAIL/SKIP)
*/
void log_test_result(const char *word_name, TestResult result) {
if (current_level == LOG_NONE || current_level < LOG_TEST)
return;
char timestamp[16];
get_timestamp(timestamp, sizeof(timestamp));
#ifndef STARFORTH_MINIMAL
const char *color;
#endif
const char *status;
switch (result) {
case TEST_PASS:
#ifndef STARFORTH_MINIMAL
color = test_pass_color;
#endif
status = "PASS";
break;
case TEST_FAIL:
#ifndef STARFORTH_MINIMAL
color = test_fail_color;
#endif
status = "FAIL";
break;
case TEST_SKIP:
#ifndef STARFORTH_MINIMAL
color = test_skip_color;
#endif
status = "SKIP";
break;
default:
#ifndef STARFORTH_MINIMAL
color = color_reset;
#endif
status = "????";
break;
}
#ifndef STARFORTH_MINIMAL
fprintf(stderr, "\x1b[35m[%s] TEST: %sTesting %-12s ... %s%s%s\n",
timestamp, color_reset, word_name, color, status, color_reset);
#else
fprintf(stderr, "[%s] TEST: Testing %-12s ... %s\n",
timestamp, word_name, status);
#endif
}
v3/src/main.c
+563
View File
@@ -0,0 +1,563 @@
/*
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 "vm.h"
#include "vm_debug.h"
#include "log.h"
#include "profiler.h"
#include "physics_runtime.h"
#include "platform_time.h"
#include "version.h"
#include "cli.h"
#include "block_subsystem.h"
#include "test_runner/include/test_runner.h"
#include "test_runner/include/test_common.h" /* brings in extern int fail_fast; */
#include "doe_metrics.h"
#include "blkio.h"
#include "blkio_factory.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <signal.h>
#include <ctype.h>
#include <stdint.h>
#ifdef __unix__
#include <sys/mman.h>
#include <unistd.h>
#ifndef MAP_ANONYMOUS
#define MAP_ANONYMOUS MAP_ANON
#endif
#endif
#ifndef BLKIO_FORTH_BLOCK_SIZE
#define BLKIO_FORTH_BLOCK_SIZE 1024u
#endif
#ifndef STARFORTH_STATE_BYTES
#define STARFORTH_STATE_BYTES 8192u
#endif
/* Optional hook (weak): if your block layer exposes an attach function, we call it. */
#if defined(__GNUC__) || defined(__clang__)
__attribute__ ((weak))
#endif
void blk_layer_attach_device(blkio_dev_t * dev);
/* Global VM pointer for cleanup */
static VM* global_vm = NULL;
/* Global blkio device + RAM backing (for cleanup) */
static blkio_dev_t g_blkio = {0};
static int g_blkio_opened = 0;
static uint8_t* g_ram_base = NULL;
static size_t g_ram_bytes = 0;
static int g_ram_is_mmap = 0;
/* Cleanup function for atexit() and signal handlers */
static void cleanup_blkio(void)
{
if (g_blkio_opened)
{
blkio_flush(&g_blkio);
blkio_close(&g_blkio);
g_blkio_opened = 0;
}
#ifdef __unix__
if (g_ram_base)
{
if (g_ram_is_mmap) munmap(g_ram_base, g_ram_bytes);
else free(g_ram_base);
g_ram_base = NULL;
g_ram_bytes = 0;
g_ram_is_mmap = 0;
}
#else
if (g_ram_base)
{
free(g_ram_base);
g_ram_base = NULL;
g_ram_bytes = 0;
}
#endif
}
/**
* @brief Performs cleanup operations before program termination
*/
void cleanup_and_exit(void)
{
/* close blkio & free RAM before VM */
cleanup_blkio();
physics_runtime_shutdown();
if (global_vm != NULL)
{
vm_cleanup(global_vm);
global_vm = NULL;
}
}
/* Signal handler for CTRL-C (SIGINT) and SIGTERM */
void signal_handler(int sig)
{
switch (sig)
{
case SIGINT: printf("\nInterrupted! Cleaning up...\n");
break;
case SIGTERM: printf("\nTerminating! Cleaning up...\n");
break;
default: break;
}
cleanup_and_exit();
exit(0);
}
/**
* @brief Prints program usage information
* @param program_name Name of the executable
*/
void print_usage(const char* program_name)
{
printf("Usage: %s [OPTIONS]\n", program_name);
printf("StarForth - A lightweight Forth virtual machine\n\n");
printf("Options:\n");
printf(" --stress-tests Run stress tests (deep nesting, stack exhaustion, large definitions)\n");
printf(" --integration Run integration tests (complete Forth programs)\n");
printf(" --break-me 🔥 ULTRA-COMPREHENSIVE diagnostic mode - tests EVERYTHING,\n");
printf(" generates detailed markdown report, includes easter egg surprise!\n");
printf(" --benchmark [N] Run performance benchmarks (default: 1000 iterations)\n");
printf(" (exits after benchmarking, does not start REPL)\n");
printf(" --log-error Set logging level to ERROR (only errors)\n");
printf(" --log-warn Set logging level to WARN (warnings and errors)\n");
printf(" --log-info Set logging level to INFO (default)\n");
printf(" --log-test Set logging level to TEST (test results only)\n");
printf(" --log-debug Set logging level to DEBUG (all messages)\n");
printf(" --log-none Disable all logging (maximum performance)\n");
printf(" --fail-fast Stop test suite immediately on first failure\n");
printf(" --profile [0-3] Enable profiler: 1=basic, 2=detailed, 3=full\n");
printf(" --profile-report Emit profiler report on exit\n");
printf(" --disk-img=<path> Use raw disk image file at <path>\n");
printf(" --disk-ro Open disk image read-only\n");
printf(" --ram-disk=<MB> RAM fallback size if no --disk-img (default: 1 MB)\n");
printf(" --fbs=<bytes> Forth block size (default: 1024)\n");
printf(" --version, -v Show version information and exit\n");
printf(" --help, -h Show this help message\n\n");
printf("Tests are executed automatically before the REPL starts.\n\n");
printf("Examples:\n");
printf(" %s # Start REPL with INFO logging\n", program_name);
printf(" %s --benchmark # Run benchmarks with 1000 iterations\n", program_name);
printf(" %s --benchmark 5000 # Run benchmarks with 5000 iterations\n", program_name);
printf(" %s --disk-img=./disks/starship.img # Use disk image\n", program_name);
printf(" %s --ram-disk=64 --fbs=1024 # 64 MB RAM fallback\n", program_name);
}
/* ============================================================================
* STATIC HELPER FUNCTIONS
* ============================================================================ */
/**
* @brief Initialize block I/O from CLI configuration
*/
static int init_blkio(const CLIConfig* config)
{
const int requested_file = (config->disk_img_path && *config->disk_img_path) ? 1 : 0;
int using_file = requested_file;
/* Verify file accessibility if requested */
if (requested_file)
{
FILE* chk = fopen(config->disk_img_path, "rb");
if (!chk)
{
log_message(LOG_WARN,
"Disk image '%s' not found or not accessible; falling back to RAM disk",
config->disk_img_path);
using_file = 0;
}
else
{
fclose(chk);
}
}
/* Compute RAM geometry (FBS fixed at 1024 bytes) */
uint64_t ram_bytes_u64 = (uint64_t)config->ram_disk_mb * 1024ull * 1024ull;
uint32_t fbs = BLKIO_FORTH_BLOCK_SIZE;
uint32_t ram_blocks = (uint32_t)(ram_bytes_u64 / (uint64_t)fbs);
g_ram_bytes = (size_t)ram_blocks * (size_t)fbs;
/* Allocate RAM backing if not using file */
if (!using_file)
{
if (g_ram_bytes == 0)
{
g_ram_bytes = (size_t)fbs;
}
#ifdef __unix__
void* p = mmap(NULL, g_ram_bytes, PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANONYMOUS
#ifdef MAP_NORESERVE
| MAP_NORESERVE
#endif
, -1, 0);
if (p != MAP_FAILED)
{
g_ram_is_mmap = 1;
g_ram_base = (uint8_t*)p;
}
#endif
if (!g_ram_base)
{
g_ram_base = (uint8_t*)malloc(g_ram_bytes);
if (!g_ram_base)
{
fprintf(stderr, "Failed to allocate RAM-disk (%zu bytes)\n", g_ram_bytes);
return 1;
}
}
}
/* Open block device */
static uint8_t state_buf[STARFORTH_STATE_BYTES];
uint8_t used_file = 0;
const uint32_t total_blocks_hint = 0;
int rc = blkio_factory_open(&g_blkio,
using_file ? config->disk_img_path : NULL,
0, /* disk_read_only: always false */
total_blocks_hint,
fbs,
state_buf, sizeof(state_buf),
g_ram_base,
(uint32_t)(g_ram_bytes / (size_t)fbs),
&used_file);
if (rc != BLKIO_OK)
{
if (using_file)
fprintf(stderr, "Failed to open disk image '%s' (rc=%d)\n", config->disk_img_path, rc);
else
fprintf(stderr, "Failed to initialize RAM backend (rc=%d)\n", rc);
return 1;
}
g_blkio_opened = 1;
/* Log geometry */
blkio_info_t info = {0};
if (blkio_info(&g_blkio, &info) == BLKIO_OK)
{
log_message(LOG_INFO,
"blkio: backend=%s fbs=%u blocks=%u size=%lluB ro=%u",
used_file ? "FILE" : "RAM",
(unsigned)info.forth_block_size,
(unsigned)info.total_blocks,
(unsigned long long)info.phys_size_bytes,
(unsigned)info.read_only);
}
return 0;
}
/**
* @brief Initialize VM core and block subsystem
*/
static int init_vm_and_subsystem(VM* vm)
{
/* Initialize VM */
vm_init(vm);
setvbuf(stdout, NULL, _IOFBF, 1 << 16);
if (vm->error)
{
fprintf(stderr, "Failed to initialize VM\n");
return 1;
}
/* Initialize block subsystem */
extern int blk_subsys_init(VM* vm, uint8_t* ram_base, size_t ram_size);
static uint8_t blk_ram[BLK_RAM_BLOCKS * BLK_FORTH_SIZE];
int rc = blk_subsys_init(vm, blk_ram, sizeof(blk_ram));
if (rc != 0)
{
fprintf(stderr, "Failed to initialize block subsystem (rc=%d)\n", rc);
return 1;
}
/* Attach blkio device */
if (g_blkio_opened && blk_layer_attach_device)
{
blk_layer_attach_device(&g_blkio);
}
return 0;
}
/**
* @brief Run benchmark mode and exit
*/
static void run_benchmark_mode(VM* vm, const CLIConfig* config)
{
log_message(LOG_INFO, "==============================================");
log_message(LOG_INFO, " StarForth Performance Benchmark Suite");
log_message(LOG_INFO, "==============================================\n");
/* run_compute_benchmarks(vm); */
log_message(LOG_INFO, "\n==============================================");
log_message(LOG_INFO, " Full Test Suite Benchmark");
log_message(LOG_INFO, " (Running %d iterations per module)", config->benchmark_iterations);
log_message(LOG_INFO, "==============================================\n");
enable_benchmark_mode(config->benchmark_iterations);
run_all_tests(vm);
}
/**
* @brief Run optional test modes after system initialization
*/
static void run_optional_tests(VM* vm, const CLIConfig* config)
{
if (config->break_me)
{
run_break_me_tests(vm);
}
}
/**
* @brief Run Design of Experiments experiment
*
* Executes the full test harness N times, collecting metrics after each run.
* Writes results to CSV file for statistical analysis.
*/
static void run_doe_experiment(VM* vm)
{
/* Reset statistics for clean start */
vm_interpret(vm, "PHYSICS-RESET-STATS");
/* Capture CPU state before run */
/* HISTORICAL: this TODO asked about l4re/POSIX separation of concern
* for these metrics -- moot now that L4Re has been removed as an
* active target; POSIX is the only path. */
int32_t cpu_temp_before = metrics_get_cpu_temp_c();
int32_t cpu_freq_before = metrics_get_cpu_freq_mhz();
/* Capture monotonic time before workload */
sf_time_ns_t workload_start_ns = sf_monotonic_ns();
/* Run test harness once (all 936+ tests) */
run_all_tests(vm);
/* Capture monotonic time after workload */
sf_time_ns_t workload_end_ns = sf_monotonic_ns();
/* Calculate actual VM workload execution time in nanoseconds */
uint64_t workload_duration_ns = workload_end_ns - workload_start_ns;
/* Capture CPU state after run */
int32_t cpu_temp_after = metrics_get_cpu_temp_c();
int32_t cpu_freq_after = metrics_get_cpu_freq_mhz();
/* Calculate deltas and convert to Q48.16 */
int32_t cpu_temp_delta = cpu_temp_after - cpu_temp_before;
int32_t cpu_freq_delta = cpu_freq_after - cpu_freq_before;
/* DEBUG: Log final rolling window state before metrics extraction */
log_message(LOG_INFO, "DoE FINAL STATE: rolling_window.total_executions=%lu, is_warm=%d, effective_window_size=%u",
vm->rolling_window.total_executions,
vm->rolling_window.is_warm,
vm->rolling_window.effective_window_size);
/* Extract metrics from VM with deltas */
DoeMetrics metrics = metrics_from_vm(vm, workload_duration_ns,
cpu_temp_delta, cpu_freq_delta);
/* CSV output suppressed - metrics collected but not printed to stdout.
* Rationale: DoE experiments now rely on internal VM metrics and test output only.
* The CSV row is redundant and interferes with clean test harness output.
* If CSV export is needed in the future, consider writing to a file instead
* of stdout, or add a --csv-export flag. */
/* metrics_write_csv_row(stdout, &metrics); */
(void)metrics; /* Suppress unused variable warning */
}
/* ============================================================================
* MAIN ENTRY POINT
* ============================================================================ */
/**
* @brief Main entry point for StarForth
*/
int main(int argc, char* argv[])
{
/* Parse command line arguments */
CLIConfig config = cli_parse(argc, argv);
/* Initialize platform time subsystem FIRST */
sf_time_init();
/* Register cleanup function and signal handlers */
atexit(cleanup_and_exit);
signal(SIGINT, signal_handler); /* CTRL-C */
signal(SIGTERM, signal_handler); /* Termination */
/* DoE mode: force LOG_NONE immediately to suppress all output except CSV */
if (config.doe_experiment)
{
config.log_level = LOG_NONE;
}
/* Initialize logging and profiling */
if (config.run_tests_flag_observed && !config.log_level_explicitly_set && !config.benchmark && !config.doe_experiment)
{
config.log_level = LOG_TEST;
}
log_set_level(config.log_level);
if (physics_runtime_init(0) != 0)
{
log_message(LOG_WARN, "Physics runtime failed to allocate analytics heap; proceeding degraded");
}
if (config.run_tests_flag_observed)
{
log_message(LOG_WARN, "--run-tests flag is obsolete; tests now run automatically.");
if (!config.log_level_explicitly_set && !config.benchmark)
{
log_message(LOG_INFO, "Test mode enabled - using LOG_TEST level for diagnostics");
}
}
/* Initialize block I/O device */
if (init_blkio(&config) != 0)
{
cleanup_and_exit();
return 1;
}
/* Initialize VM and block subsystem */
VM vm = {0};
global_vm = &vm;
if (init_vm_and_subsystem(&vm) != 0)
{
cleanup_and_exit();
return 1;
}
/* Register VM lifecycle words (BIRTH KILL PAUSE RESUME USE) */
extern void register_lifecycle_words(VM *vm);
register_lifecycle_words(&vm);
/* Install VM debug hooks */
vm_debug_set_current_vm(&vm);
vm_debug_install_signal_handlers();
/* Handle DoE experiment mode (exits after) */
if (config.doe_experiment)
{
/* Force LOG_NONE so only CSV goes to stdout */
log_set_level(LOG_NONE);
/* Run DoE experiment - returns non-zero on runtime failure */
run_doe_experiment(&vm);
/* Check for VM errors (runtime instability) */
if (vm.error)
{
cleanup_and_exit();
return 2; /* Runtime failure */
}
cleanup_and_exit();
return 0; /* Success */
}
/* Handle benchmark mode (exits after) */
if (config.benchmark)
{
run_benchmark_mode(&vm, &config);
cleanup_and_exit();
return 0;
}
/* Apply global fail-fast flag to test framework */
if (config.fail_fast)
{
fail_fast = 1;
}
/* Protect foundational words from FORGET */
vm.dict_fence_latest = vm.latest;
vm.dict_fence_here = vm.here;
log_message(LOG_INFO, "Dictionary fence set - init words protected from FORGET");
/* Run optional test modes */
run_optional_tests(&vm, &config);
/* Start REPL unless --break-me was specified */
if (!config.break_me)
{
/* Always run the full test suite immediately prior to REPL */
log_message(LOG_INFO, "Running comprehensive test suite...");
run_all_tests(&vm);
log_message(LOG_INFO, "Test run complete.");
/* Run system initialization AFTER POST completes */
log_message(LOG_INFO, "Running system initialization (INIT)...");
vm_interpret(&vm, "INIT");
if (vm.error)
{
log_message(LOG_ERROR, "System initialization failed - cannot continue");
cleanup_and_exit();
return 1;
}
log_message(LOG_INFO, "System initialization complete.");
vm_repl(&vm, config.script_mode);
}
cleanup_and_exit();
return 0;
}
v3/src/math_portable.c
+263
View File
@@ -0,0 +1,263 @@
/*
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.
*/
/*
* math_portable.c
*
* Pure 64-bit fixed-point Q48.16 math functions.
* Suitable for embedded environments with no libm or floating-point
* (HISTORICAL: also L4Re, through mid-2026; removed as an active target).
* All arithmetic is integer-only for maximum production performance.
*
* Q48.16 Format:
* - 48-bit signed integer + 16-bit fractional part
* - 1.0 = 65536 (2^16)
* - Precision: 2^-16 ≈ 0.0000153
* - Range: ±140 trillion
*/
#include <stdint.h>
#include "math_portable.h"
/**
* @brief Compute exp(@p x) via Taylor series in Q48.16 fixed-point.
*
* Evaluates the classic Taylor expansion:
* @code
* exp(x) = 1 + x + x²/2! + x³/3! + … (up to 40 terms)
* @endcode
* entirely in 64-bit integer arithmetic using the Q48.16 representation
* (1.0 = 65536 = 2^16).
*
* The function is intentionally scoped to the range the physics engine
* actually uses — the argument to @c erf_q48() is @c -x² times a ratio
* near 1, yielding values in roughly the @c [-20, 0] interval. Outside
* this range the implementation provides coarse-grained clamping:
* - @p x == 0 → returns @c Q48 (1.0 exactly)
* - @p x > 20.0 → saturates at @c Q48 << 8 (approx e^20, avoids overflow)
* - @p x < -100.0 → underflows to 0 (result is negligible)
*
* The term loop exits early on the first term smaller than 1 ULP (the
* series has converged) and guards against intermediate overflow by
* clamping @c result at @c INT64_MAX-1.
*
* @note This is a file-local (@c static) helper; callers are
* @c erf_q48() only.
*
* @param x Input value in Q48.16 format (1.0 = 65536). Intended range:
* approximately [-100×65536, +20×65536].
* @return exp(@p x) in Q48.16 format; 0 on underflow; saturated at
* @c INT64_MAX-1 on overflow.
*/
static int64_t exp_q48(int64_t x) {
const int64_t Q48 = 65536LL; /* 2^16 */
/* Handle extremes */
if (x == 0) return Q48;
if (x > (20LL << 16)) return Q48 << 8; /* Approximate e^20 */
if (x < -(100LL << 16)) return 0; /* Underflow to zero */
/* Taylor series: exp(x) = Σ x^n / n! (in fixed-point) */
int64_t result = Q48; /* Start with 1 */
int64_t term = Q48;
int64_t x_power = x; /* x^1 */
for (int i = 1; i < 40; i++) {
/* term = x^i / i! */
term = (x_power / (int64_t)i) / Q48; /* Scale down to avoid overflow */
if (term > -1 && term < 1) break; /* Negligible */
result += term;
x_power = (x_power * x) / Q48; /* Keep x^n scaled */
/* Guard against overflow */
if (result < 0 && result < (1LL << 62)) break;
if (result > 0 && result > (1LL << 62)) {
result = 9223372036854775806LL; /* Saturate at INT64_MAX-1 */
break;
}
}
return result;
}
/**
* @brief Compute sqrt(@p x) via Newton-Raphson in Q48.16 fixed-point.
*
* Applies the Newton-Raphson recurrence:
* @code
* r_{n+1} = (r_n² + x) / (2 × r_n)
* @endcode
* for up to 20 iterations, with all arithmetic scaled to the Q48.16
* representation (1.0 = 65536). Intermediate products use 8-bit right
* shifts on both operands before squaring to prevent 64-bit overflow:
* @code
* guess_squared = (guess >> 8) * (guess >> 8)
* @endcode
* This sacrifices 16 bits of precision in the squared term, which is
* acceptable because the division by @c 2*guess restores the correct
* order of magnitude. Convergence is declared when successive iterates
* differ by at most 1 in Q48.16 units (sub-nanosecond for timing uses).
*
* Special cases handled without iteration:
* - @p x ≤ 0 → returns 0 (no imaginary results)
* - @p x == 65536 (1.0) → returns 65536 exactly
*
* Initial guess: @c x/2 for @p x > 1.0, else @c 1.0. Values above 1.0
* converge from above; values in (0, 1.0) converge from the 1.0 initial
* guess.
*
* @param x Non-negative value in Q48.16 format (1.0 = 65536).
* Negative values are treated as zero.
* @return sqrt(@p x) in Q48.16 format; 0 for @p x ≤ 0.
*/
int64_t sqrt_q48(int64_t x) {
const int64_t Q48 = 65536LL;
/* Handle special cases */
if (x < 0) return 0;
if (x == 0) return 0;
if (x == Q48) return Q48; /* sqrt(1.0) = 1.0 */
/* Initial guess: average of x and 1 */
int64_t guess = (x > Q48) ? (x >> 1) : Q48;
/* Newton-Raphson iterations */
for (int i = 0; i < 20; i++) {
/* next = (guess^2 + x) / (2 * guess)
* In Q48.16: (guess^2) >> 16 + x, then divide by 2*guess
*/
int64_t guess_squared = (guess >> 8) * (guess >> 8); /* Avoid overflow */
int64_t next = (guess_squared + (x >> 16)) / (2 * guess);
/* Check convergence */
int64_t diff = next - guess;
if (diff > -2 && diff < 2) return next;
guess = next;
}
return guess;
}
/**
* @brief Compute erf(@p x) via Abramowitz & Stegun 7.1.26 in Q48.16 fixed-point.
*
* Implements the rational approximation from Abramowitz & Stegun, formula 7.1.26:
* @code
* erf(x) ≈ sign(x) × sqrt(1 − exp(−x² × (4/π + a·x²) / (1 + a·x²)))
* @endcode
* where @c a ≈ 0.147 (in Q48.16: 9633). The maximum error of the true
* mathematical approximation is @c |ε| < 1.5×10⁻⁷; the fixed-point
* encoding introduces additional rounding of approximately 1 ULP in Q48.16.
*
* All arithmetic is performed in 64-bit integer Q48.16 format — no
* floating-point operations. The computation sequence:
* 1. Extract sign; work with @c |x|.
* 2. Compute @c x² with 8-bit prescaling to prevent overflow:
* @c x_sq = (x >> 8) * (x >> 8).
* 3. Evaluate the A&S numerator @c (4/π + a·x²) and denominator @c (1 + a·x²).
* 4. Compute @c ratio = numerator / denominator (shift to preserve Q48.16 scale).
* 5. Compute @c exp_arg = −x² × ratio and evaluate @c exp_q48(exp_arg).
* 6. Compute @c base = 1 − exp_val, clamp to [0, 1].
* 7. Return @c sign × sqrt_q48(base).
*
* Q48.16 constants used:
* - @c a_q48 = 9633 (0.147 × 65536)
* - @c four_over_pi_q48 = 83328 (4/π × 65536 ≈ 1.2732 × 65536)
*
* Consumed by @c hotwords_speedup_estimate() to compute P(speedup > 1.1×)
* and P(speedup > 2.0×) via the normal CDF identity:
* @code
* P(Z ≤ z) = 0.5 × (1 + erf(z / √2))
* @endcode
* where @c √2 in Q48.16 = 92681.
*
* @param x Input value in Q48.16 format (dimensionless Z-score;
* 1.0 = 65536). May be negative; sign determines the sign
* of the result.
* @return erf(@p x) in Q48.16 format, in the range [−65536, +65536]
* corresponding to (−1.0, +1.0).
*/
int64_t erf_q48(int64_t x) {
const int64_t Q48 = 65536LL;
if (x == 0) return 0;
/* Compute sign and work with absolute value */
int sign = (x < 0) ? -1 : 1;
if (x < 0) x = -x;
/* Abramowitz & Stegun coefficient a ≈ 0.147 (in Q48.16) */
const int64_t a_q48 = 9633LL; /* 0.147 * 65536 */
const int64_t four_over_pi_q48 = 83328LL; /* 4/π * 65536 */
/* Compute x^2 in Q48.16 */
int64_t x_sq = (x >> 8) * (x >> 8); /* Scaled to avoid overflow */
/* Compute denominator: 1 + a*x^2 */
int64_t denom = Q48 + ((a_q48 * x_sq) >> 16);
if (denom == 0) denom = 1; /* Guard divide-by-zero */
/* Compute numerator: 4/π + a*x^2 */
int64_t numer = four_over_pi_q48 + ((a_q48 * x_sq) >> 16);
/* Compute ratio = numerator / denominator */
int64_t ratio = (numer << 16) / denom;
/* Compute exp argument: -x^2 * ratio */
int64_t exp_arg = -(x_sq * ratio / Q48);
/* Compute exp(-x^2 * ratio) */
int64_t exp_val = exp_q48(exp_arg);
/* Compute base: 1 - exp(exp_arg) */
int64_t base = Q48 - exp_val;
if (base < 0) base = 0;
if (base > Q48) base = Q48;
/* Compute sqrt(base) */
int64_t sqrt_base = sqrt_q48(base);
/* Apply sign and return */
return sign * sqrt_base;
}
v3/src/memory_management.c
+140
View File
@@ -0,0 +1,140 @@
/*
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/vm.h"
#include "../include/log.h"
/**
* @brief Allocates memory from the VM's dictionary space
* @param vm Pointer to the VM instance
* @param bytes Number of bytes to allocate
* @return Pointer to the allocated memory or NULL if allocation fails
* @note The allocation is done from the VM's dictionary space which is limited to DICTIONARY_MEMORY_SIZE
*/
void *vm_allot(VM *vm, size_t bytes) {
if (!vm || !vm->memory) {
log_message(LOG_ERROR, "vm_allot: VM or memory is NULL");
return NULL;
}
/* Ensure we don't allocate beyond dictionary space (first DICTIONARY_BLOCKS blocks = DICTIONARY_MEMORY_SIZE bytes) */
log_message(LOG_DEBUG, "vm_allot: Requesting %zu bytes, current here=%zu, limit=%d",
bytes, vm->here, DICTIONARY_MEMORY_SIZE);
if (vm->here + bytes >= DICTIONARY_MEMORY_SIZE) {
log_message(LOG_ERROR, "Dictionary space full (here=%zu, bytes=%zu, dict_limit=%d)",
vm->here, bytes, DICTIONARY_MEMORY_SIZE);
vm->error = 1;
return NULL;
}
void *ptr = vm->memory + vm->here;
vm->here += bytes;
/* Log which block we're using */
int current_block = vm->here / BLOCK_SIZE;
log_message(LOG_DEBUG, "ALLOT: Allocated %zu bytes at offset %zu (block %d)",
bytes, vm->here - bytes, current_block);
return ptr;
}
/**
* @brief Aligns the VM's dictionary pointer (here) to the cell boundary
* @param vm Pointer to the VM instance
* @note Adds padding bytes if necessary to ensure proper alignment for cell_t type
*/
void vm_align(VM *vm) {
size_t align = sizeof(cell_t);
size_t misalignment = vm->here % align;
if (misalignment != 0) {
size_t padding = align - misalignment;
void *pad = vm_allot(vm, padding);
if (pad == NULL) {
log_message(LOG_ERROR, "vm_align: Out of memory while aligning");
vm->error = 1;
return;
}
/* Optional: zero out the padding */
unsigned char *bytes = (unsigned char *) pad;
for (size_t i = 0; i < padding; ++i) {
bytes[i] = 0;
}
log_message(LOG_DEBUG, "vm_align: Added %zu byte(s) of padding", padding);
}
}
/**
* @brief Gets the memory address for a specified block number
* @param vm Pointer to the VM instance
* @param block_num Block number to get the address for
* @return Pointer to the start of the block or NULL if block number is invalid
* @note Blocks are fixed-size memory regions of BLOCK_SIZE bytes
*/
void *vm_get_block_addr(VM *vm, int block_num) {
if (block_num < 0 || block_num >= MAX_BLOCKS) {
log_message(LOG_ERROR, "vm_get_block_addr: Invalid block number %d", block_num);
return NULL;
}
return vm->memory + (block_num * BLOCK_SIZE);
}
/* Convert address to block number */
/**
* @brief Converts a memory address to its corresponding block number
* @param vm Pointer to the VM instance
* @param addr Memory address to convert
* @return Block number (0 to MAX_BLOCKS-1) or -1 if address is outside VM memory
* @note Used for determining which block a memory address belongs to
*/
int vm_addr_to_block(VM *vm, void *addr) {
if (addr < (void *) vm->memory ||
addr >= (void *) (vm->memory + VM_MEMORY_SIZE)) {
return -1; /* Outside VM memory */
}
uintptr_t offset = (uintptr_t) addr - (uintptr_t) vm->memory;
return (int) (offset / BLOCK_SIZE);
}
v3/src/physics_execution_hooks.c
+223
View File
@@ -0,0 +1,223 @@
/*
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.
*/
/*
* physics_execution_hooks.c - All physics machinery in one place
*
* This file absorbs ALL the physics-related code that was scattered
* throughout execute_colon_word and vm_interpret_word.
*
* The VM execution loop is now clean; this file is where physics lives.
*/
#include "../include/physics_execution_hooks.h"
#include "../include/platform_time.h"
#include "../include/profiler.h"
#include "../include/physics_metadata.h"
#include "../include/physics_hotwords_cache.h"
#include "../include/physics_pipelining_metrics.h"
#include "../include/rolling_window_of_truth.h"
#include "../include/ssm_jacquard.h"
/**
* @brief Pre-execution physics hook — called before every word dispatch.
*
* Consolidates all physics work that must happen before a word runs:
* - Loop #3: applies linear decay based on elapsed time since last execution
* - Loop #1: increments @c execution_heat for the word
* - Loop #2: records the word-id into the rolling window of truth
* - Loop #4: detects a pipelining prefetch hit (if @c prev's speculation
* matched @c word), records the transition from @c prev to @c word,
* updates the probability cache, and issues a speculative hotwords
* cache promotion for the most likely next word
*
* @param vm Pointer to the VM structure
* @param word DictEntry being executed
* @param prev DictEntry executed immediately before @c word (may be NULL)
*/
void physics_pre_execute(VM* vm, DictEntry* word, DictEntry* prev)
{
if (!vm || !word) return;
uint64_t now_ns = sf_monotonic_ns();
/* Loop #3: Apply linear decay before accumulating new heat.
* Tick-based, not wall-clock -- see physics_metadata_apply_linear_decay(). */
uint64_t elapsed_ticks = vm->heartbeat.tick_count - word->physics.last_decay_tick;
physics_metadata_apply_linear_decay(word, elapsed_ticks, vm);
word->physics.last_decay_tick = vm->heartbeat.tick_count;
word->physics.last_active_ns = now_ns;
word->physics.last_decay_ns = now_ns;
/* Loop #1: Heat accumulation */
physics_execution_heat_increment(word);
uint32_t word_id = word->word_id;
if (word_id >= DICTIONARY_SIZE) return;
/* Loop #2: Rolling Window of Truth */
rolling_window_record_execution(&vm->rolling_window, word_id);
/* Loop #4: Pipelining Transition Metrics. ENABLE_PIPELINING is the
* compile-time ceiling; ssm_config's L4_pipelining is L8's live
* runtime toggle within that ceiling (see ssm_jacquard.h). */
{
ssm_config_t *ssm_cfg = (ssm_config_t*)vm->ssm_config;
if (!prev || !prev->transition_metrics || !ENABLE_PIPELINING ||
!ssm_cfg || !ssm_cfg->L4_pipelining) return;
}
/* Check if current word was speculatively promoted by previous word */
uint32_t prev_speculation_target = prev->transition_metrics->most_likely_next_word_id;
if (prev_speculation_target == word_id && prev->transition_metrics->prefetch_attempts > 0)
{
/* PREFETCH HIT: Current word matches previous word's speculation! */
transition_metrics_record_prefetch_hit(prev->transition_metrics, 0);
vm->pipeline_metrics.prefetch_hits++;
}
/* Record transition from previous word to current word */
transition_metrics_record(prev->transition_metrics, word_id, DICTIONARY_SIZE);
/* Update probability cache to find most likely next word */
transition_metrics_update_cache(prev->transition_metrics, DICTIONARY_SIZE);
uint32_t speculated_word_id = prev->transition_metrics->most_likely_next_word_id;
/* Speculative prefetch of most likely next word */
if (speculated_word_id < DICTIONARY_SIZE &&
transition_metrics_should_speculate(prev->transition_metrics, speculated_word_id))
{
DictEntry* spec_entry = vm_dictionary_lookup_by_word_id(vm, speculated_word_id);
/* ENABLE_HOTWORDS_CACHE is the compile-time ceiling; cache->enabled
* is L8's live runtime toggle within that ceiling, kept in sync
* with ssm_config's L1_heat_tracking wherever L8 applies a config
* (see vm_time.c / vm_runtime.c). */
if (spec_entry && vm->hotwords_cache && ENABLE_HOTWORDS_CACHE &&
vm->hotwords_cache->enabled)
{
spec_entry->execution_heat = HOTWORDS_EXECUTION_HEAT_THRESHOLD + 1;
hotwords_cache_promote(vm->hotwords_cache, spec_entry);
prev->transition_metrics->prefetch_attempts++;
vm->pipeline_metrics.prefetch_attempts++;
}
}
}
/**
* @brief Post-execution physics hook — called after every word dispatch.
*
* Consolidates all physics work that must happen after a word completes:
* - Updates physics metadata (@c temperature_q8, @c last_active_ns) via
* @c physics_metadata_touch()
* - Notifies the profiler (@c profiler_word_exit())
* - Increments @c vm->heartbeat.words_executed
* - When running without a background heartbeat thread, checks whether
* enough words have been executed to trigger a heartbeat cycle
* (@c vm_heartbeat_run_cycle())
*
* @param vm Pointer to the VM structure
* @param word DictEntry that just finished executing
*/
void physics_post_execute(VM* vm, DictEntry* word)
{
if (!vm || !word) return;
physics_metadata_touch(word, word->execution_heat, sf_monotonic_ns());
profiler_word_exit(word);
vm->heartbeat.words_executed++;
/* Heartbeat: Periodic time-driven tuning (Loop #3 & #5) */
if (!vm->heartbeat.worker && ++vm->heartbeat.check_counter >= HEARTBEAT_CHECK_FREQUENCY)
{
extern void vm_heartbeat_run_cycle(VM* vm);
vm_heartbeat_run_cycle(vm);
vm->heartbeat.check_counter = 0;
}
}
/**
* @brief Physics hook for the outer interpreter word-lookup path.
*
* Called when the outer interpreter successfully finds a word by name,
* before executing it. Applies linear decay and increments heat on both
* the found entry and the canonical entry (if different), and updates
* @c last_active_ns / @c last_decay_ns on both. Acquires @c vm->dict_lock
* for the entire operation to ensure thread safety.
*
* @param vm Pointer to the VM structure
* @param entry DictEntry found by name search
* @param canon Canonical DictEntry (may equal @c entry or be the smudge target)
*/
void physics_on_lookup(VM* vm, DictEntry* entry, DictEntry* canon)
{
if (!vm || !entry) return;
uint64_t lookup_ns = sf_monotonic_ns();
sf_mutex_lock(&vm->dict_lock);
/* Apply decay and heat to found entry. Tick-based, not wall-clock --
* see physics_metadata_apply_linear_decay(). */
uint64_t elapsed_entry_ticks = vm->heartbeat.tick_count - entry->physics.last_decay_tick;
physics_metadata_apply_linear_decay(entry, elapsed_entry_ticks, vm);
entry->physics.last_decay_tick = vm->heartbeat.tick_count;
entry->physics.last_active_ns = lookup_ns;
entry->physics.last_decay_ns = lookup_ns;
physics_execution_heat_increment(entry);
/* Also handle canonical entry if different */
if (canon && canon != entry)
{
uint64_t elapsed_canon_ticks = vm->heartbeat.tick_count - canon->physics.last_decay_tick;
physics_metadata_apply_linear_decay(canon, elapsed_canon_ticks, vm);
canon->physics.last_decay_tick = vm->heartbeat.tick_count;
canon->physics.last_active_ns = lookup_ns;
canon->physics.last_decay_ns = lookup_ns;
physics_execution_heat_increment(canon);
physics_metadata_touch(canon, canon->execution_heat, lookup_ns);
}
sf_mutex_unlock(&vm->dict_lock);
}
v3/src/physics_hotwords_cache.c
+991
View File
@@ -0,0 +1,991 @@
/*
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.
*/
/*
* physics_hotwords_cache.c
*
* Hot-words cache implementation
* Provides frequency-driven dictionary acceleration via LRU cache
*/
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include "physics_hotwords_cache.h"
/* In kernel builds, suppress platform_time.h inline wrappers to avoid
* GOTPCREL relocations in PE binaries (no GOT in PE format). shim.c
* provides the concrete sf_monotonic_ns() symbol in that case.
* PLATFORM_TIME_NO_INLINE is also set globally via COMMON_CFLAGS in
* Makefile.starkernel; the #ifndef guard prevents -Wall -Werror redefinition. */
#ifdef __STARKERNEL__
#ifndef PLATFORM_TIME_NO_INLINE
#define PLATFORM_TIME_NO_INLINE
#endif
#endif /* __STARKERNEL__ */
#include "platform_time.h"
#include "math_portable.h"
/* ============================================================================
* Global Cache Instance
* ============================================================================
*/
/* Global hot-words cache for the VM (used by benchmark and diagnostic words) */
HotwordsCache g_hotwords_cache = {0};
/* Forward declarations for helper functions */
static inline double q48_to_ns_double(int64_t q48);
/* ============================================================================
* Cache Initialization
* ============================================================================
*/
/**
* @brief Initialise a @c HotwordsCache to its empty, enabled state.
*
* Zeroes all fields via @c memset then explicitly sets:
* - @c cache->enabled = @c ENABLE_HOTWORDS_CACHE (build-time compile flag;
* 0 disables the cache globally without a code change).
* - @c cache->cache_count = 0, @c cache->lru_index = 0 — empty round-robin
* eviction ring.
* - All counter fields in @c cache->stats to 0.
* - @c stats.min_cache_hit_ns = @c INT64_MAX, @c stats.max_cache_hit_ns =
* @c INT64_MIN (sentinel values; updated to real observations on the first
* cache hit).
* - @c stats.min_bucket_search_ns = @c INT64_MAX, @c stats.max_bucket_search_ns
* = @c INT64_MIN (same sentinel convention for bucket searches).
* - All Q48.16 variance accumulators to 0.
*
* Safe to call multiple times (idempotent via @c memset). Must be called
* before the first @c hotwords_cache_lookup() invocation; failure to do so
* leaves the sentinel min/max fields uninitialised, producing nonsense in the
* Bayesian posterior report.
*
* @param cache Cache to initialise; no-op if NULL.
*/
void hotwords_cache_init(HotwordsCache *cache) {
if (!cache) return;
memset(cache, 0, sizeof(*cache));
cache->enabled = ENABLE_HOTWORDS_CACHE;
cache->cache_count = 0;
cache->lru_index = 0;
/* Initialize statistics with proper sentinel values */
cache->stats.total_lookups = 0;
cache->stats.cache_hits = 0;
cache->stats.bucket_hits = 0;
cache->stats.misses = 0;
cache->stats.evictions = 0;
cache->stats.promotions = 0;
cache->stats.bucket_reorders = 0;
/* Fixed-point statistics (Q48.16 format) */
cache->stats.cache_hit_total_ns_q48 = 0;
cache->stats.bucket_search_total_ns_q48 = 0;
cache->stats.cache_hit_samples = 0;
cache->stats.bucket_search_samples = 0;
/* Min/max latencies */
cache->stats.min_cache_hit_ns = INT64_MAX;
cache->stats.max_cache_hit_ns = INT64_MIN;
cache->stats.min_bucket_search_ns = INT64_MAX;
cache->stats.max_bucket_search_ns = INT64_MIN;
/* Variance accumulators (Q48.16) */
cache->stats.cache_hit_variance_sum_q48 = 0;
cache->stats.bucket_search_variance_sum_q48 = 0;
}
/**
* @brief Zero all fields in a @c HotwordsCache, releasing no heap memory.
*
* Calls @c memset(cache, 0, sizeof(*cache)) to scrub every field including
* the inline @c cache[] pointer array and all statistics. The cache holds no
* separately allocated memory (the @c DictEntry pointers inside @c cache[]
* are owned by the dictionary, not the cache), so no @c free() calls are
* needed.
*
* Intended for use at VM teardown or when the caller wants to reset the cache
* to a known-zero state between benchmark runs. After this call the cache
* is in an unusable state (@c enabled = 0); call @c hotwords_cache_init()
* to reinitialise it.
*
* @param cache Cache to zero; no-op if NULL.
*/
void hotwords_cache_cleanup(HotwordsCache *cache) {
if (!cache) return;
memset(cache, 0, sizeof(*cache));
}
/* ============================================================================
* Main Lookup: Cache + Bucket Search
* ============================================================================
*/
/**
* @brief Look up a FORTH word using the hot-words cache, falling back to the bucket.
*
* The primary dictionary fast-path. Records a start timestamp via
* @c sf_monotonic_ns() and then executes a two-stage search:
*
* **Stage 1 — Cache check (O(HOTWORDS_CACHE_SIZE)):**
* Scans the @c cache->cache[] ring for an entry whose @c name_len and name
* match @p name/@p len, using the cheap-first filter (@c name_len →
* last-character → @c memcmp). On a hit the elapsed nanoseconds are
* converted to Q48.16 and accumulated into @c stats.cache_hit_total_ns_q48;
* the squared value is accumulated into @c stats.cache_hit_variance_sum_q48
* for Bayesian posterior computation by @c calculate_posterior(). Min/max
* latency sentinels are also updated.
*
* **Stage 2 — Bucket fallback (O(bucket_count)):**
* Scans @p bucket[] in reverse-insertion order (newest definition wins).
* On a hit the elapsed time is recorded in the @c bucket_search_* accumulators
* with the same Q48.16 and variance treatment as Stage 1. If the found
* word's @c execution_heat exceeds @c HOTWORDS_EXECUTION_HEAT_THRESHOLD it
* is promoted into the cache via @c hotwords_cache_promote().
*
* **Disabled path:** If @c cache is NULL or @c cache->enabled is 0, the
* function skips Stage 1 and performs a bare reverse-linear scan of @p bucket[]
* returning the result immediately (no statistics are recorded).
*
* A miss increments @c stats.misses and returns NULL.
*
* @param cache Hot-words cache; may be NULL or disabled (falls back
* to bucket scan without statistics).
* @param bucket First-character hash bucket — array of @c DictEntry*
* pointers, searched in reverse order.
* @param bucket_count Number of valid pointers in @p bucket.
* @param name Word name to find (not NUL-terminated).
* @param len Length of @p name in bytes.
* @return Matching @c DictEntry*, or NULL if not found.
*/
DictEntry *hotwords_cache_lookup(VM *vm,
HotwordsCache *cache,
DictEntry **bucket,
size_t bucket_count,
const char *name,
size_t len) {
uint64_t start_ns = sf_monotonic_ns();
// Disabled? Go straight to the arbitrated bucket resolver
if (!cache || !cache->enabled) {
return vm_dict_resolve_in_bucket(vm, bucket, bucket_count, name, len);
}
cache->stats.total_lookups++;
// --- STEP 1: Check hot-words cache ---
for (uint32_t i = 0; i < cache->cache_count; i++) {
DictEntry *e = cache->cache[i];
if (!e) continue;
if ((size_t)e->name_len != len) continue;
#ifdef WORD_HIDDEN
if (e->flags & WORD_HIDDEN) continue;
#endif
#ifdef WORD_SMUDGED
if (e->flags & WORD_SMUDGED) continue;
#endif
if (len > 1 && (unsigned char)e->name[len - 1] != (unsigned char)name[len - 1]) continue;
if (memcmp(e->name, name, len) == 0) {
// Cache hit! Record latency with 64-bit fixed-point precision
cache->stats.cache_hits++;
int64_t elapsed_ns = (int64_t)(sf_monotonic_ns() - start_ns);
/* Store in Q48.16 fixed-point format (shift left by 16 bits for fractional precision) */
cache->stats.cache_hit_total_ns_q48 += (elapsed_ns << 16);
cache->stats.cache_hit_samples++;
/* Track min/max */
if (elapsed_ns < cache->stats.min_cache_hit_ns) {
cache->stats.min_cache_hit_ns = elapsed_ns;
}
if (elapsed_ns > cache->stats.max_cache_hit_ns) {
cache->stats.max_cache_hit_ns = elapsed_ns;
}
/* Accumulate squared values for variance calculation (Bayesian posteriors) */
int64_t elapsed_sq_q48 = (elapsed_ns * elapsed_ns) << 16;
cache->stats.cache_hit_variance_sum_q48 += elapsed_sq_q48;
return e;
}
}
// --- STEP 2: Fall back to bucket search (arbitrated: newest visible
// same-named definition wins regardless of heat ordering) ---
{
DictEntry *e = vm_dict_resolve_in_bucket(vm, bucket, bucket_count, name, len);
if (e) {
// Bucket hit! Record latency with 64-bit fixed-point precision
cache->stats.bucket_hits++;
int64_t elapsed_ns = (int64_t)(sf_monotonic_ns() - start_ns);
/* Store in Q48.16 fixed-point format (shift left by 16 bits for fractional precision) */
cache->stats.bucket_search_total_ns_q48 += (elapsed_ns << 16);
cache->stats.bucket_search_samples++;
/* Track min/max */
if (elapsed_ns < cache->stats.min_bucket_search_ns) {
cache->stats.min_bucket_search_ns = elapsed_ns;
}
if (elapsed_ns > cache->stats.max_bucket_search_ns) {
cache->stats.max_bucket_search_ns = elapsed_ns;
}
/* Accumulate squared values for variance calculation (Bayesian posteriors) */
int64_t elapsed_sq_q48 = (elapsed_ns * elapsed_ns) << 16;
cache->stats.bucket_search_variance_sum_q48 += elapsed_sq_q48;
// If hot enough, promote to cache
if (e->execution_heat > HOTWORDS_EXECUTION_HEAT_THRESHOLD) {
hotwords_cache_promote(cache, e);
}
return e;
}
}
// Miss
cache->stats.misses++;
return NULL;
}
/* ============================================================================
* Cache Eviction (coherence with dictionary mutations)
* ============================================================================
*/
/* Remove ring slot i, compacting the tail down one position. */
static void hotwords_cache_remove_at(HotwordsCache *cache, uint32_t i) {
for (uint32_t j = i; j + 1 < cache->cache_count; j++) {
cache->cache[j] = cache->cache[j + 1];
}
cache->cache_count--;
cache->cache[cache->cache_count] = NULL;
if (cache->lru_index >= cache->cache_count) {
cache->lru_index = 0;
}
}
void hotwords_cache_evict_entry(HotwordsCache *cache, const DictEntry *word) {
if (!cache || !word || cache->cache_count == 0) return;
for (uint32_t i = cache->cache_count; i-- > 0;) {
if (cache->cache[i] == word) {
hotwords_cache_remove_at(cache, i);
}
}
}
void hotwords_cache_evict_name(HotwordsCache *cache, const char *name, size_t len) {
if (!cache || !name || len == 0 || cache->cache_count == 0) return;
for (uint32_t i = cache->cache_count; i-- > 0;) {
DictEntry *e = cache->cache[i];
if (!e) continue;
if ((size_t)e->name_len != len) continue;
if (memcmp(e->name, name, len) != 0) continue;
hotwords_cache_remove_at(cache, i);
}
}
/* ============================================================================
* Cache Promotion (LRU eviction)
* ============================================================================
*/
/**
* @brief Promote a @c DictEntry into the hot-words cache, evicting the oldest entry if full.
*
* Two paths depending on whether the cache has a free slot:
*
* - **Slot available** (@c cache->cache_count < @c HOTWORDS_CACHE_SIZE):
* Appends @p word at @c cache->cache[cache_count++] after verifying it is
* not already present (linear scan). Increments @c stats.promotions.
*
* - **Cache full** (@c cache->cache_count >= @c HOTWORDS_CACHE_SIZE):
* Overwrites @c cache->cache[cache->lru_index] with @p word (round-robin
* least-recently-used eviction) and advances @c lru_index modulo
* @c HOTWORDS_CACHE_SIZE. Increments @c stats.evictions. The evicted entry
* is not freed — it remains alive in the dictionary; only its slot in the
* cache ring is surrendered.
*
* Called from @c hotwords_cache_lookup() whenever a bucket search finds a
* word hot enough to warrant caching (heat > @c HOTWORDS_EXECUTION_HEAT_THRESHOLD).
*
* @param cache The cache to promote into; no-op if NULL.
* @param word The @c DictEntry to promote; no-op if NULL. Ownership is not
* transferred — the cache holds a borrowed pointer into the
* dictionary, which owns the entry.
*/
void hotwords_cache_promote(HotwordsCache *cache, DictEntry *word) {
if (!cache || !word || cache->cache_count >= HOTWORDS_CACHE_SIZE) {
if (cache && cache->cache_count >= HOTWORDS_CACHE_SIZE) {
// LRU eviction: remove oldest entry (round-robin)
cache->cache[cache->lru_index] = word;
cache->lru_index = (cache->lru_index + 1) % HOTWORDS_CACHE_SIZE;
cache->stats.evictions++;
}
return;
}
// Check if already in cache
for (uint32_t i = 0; i < cache->cache_count; i++) {
if (cache->cache[i] == word) {
return; // Already cached
}
}
// Add to cache
cache->cache[cache->cache_count++] = word;
cache->stats.promotions++;
}
/* ============================================================================
* Bucket Reordering (move hot words forward)
* ============================================================================
*/
/**
* @brief Sort a hash bucket in-place by descending execution heat (bubble sort).
*
* Performs a classic in-place bubble sort over the @p bucket array so that
* words with higher @c execution_heat appear at lower array indices. The
* hot-words cache and heat-stratified lookup both benefit from having the
* hottest words at the front of each bucket: the first-character hash buckets
* are linear arrays, and placing hot words up front reduces the scan depth on
* Stage 1 cache misses that fall through to Stage 2 bucket search.
*
* Bubble sort is chosen deliberately: buckets are small (typically single
* digits to low dozens of words per first-character class), already nearly
* sorted after the previous reorganization pass, and the cost of a O(n²)
* inner loop on n ≤ 30 is negligible compared to the outer @c qsort on
* all 256 buckets in @c dict_reorganize_buckets_by_heat(). For the individual
* per-bucket call path (e.g. after a single promotion), bubble sort avoids
* the @c malloc overhead that @c qsort's temporary storage would require.
*
* No-op for @p count < 2.
*
* @param bucket Array of @c DictEntry* pointers to sort in-place.
* NULL-check is the caller's responsibility.
* @param count Number of valid entries in @p bucket.
*/
void hotwords_bucket_reorder(DictEntry **bucket, size_t count) {
if (!bucket || count < 2) return;
// Simple bubble sort: move high-execution-heat words forward
for (size_t i = 0; i < count - 1; i++) {
for (size_t j = 0; j < count - i - 1; j++) {
if (bucket[j]->execution_heat < bucket[j + 1]->execution_heat) {
// Swap
DictEntry *tmp = bucket[j];
bucket[j] = bucket[j + 1];
bucket[j + 1] = tmp;
}
}
}
}
/* ============================================================================
* Statistics
* ============================================================================
*/
/**
* @brief Zero all fields in a @c HotwordsStats structure.
*
* Resets every counter (@c total_lookups, @c cache_hits, @c bucket_hits,
* @c misses, @c evictions, @c promotions, @c bucket_reorders) to zero,
* resets all Q48.16 accumulator fields (@c cache_hit_total_ns_q48,
* @c bucket_search_total_ns_q48, @c cache_hit_variance_sum_q48,
* @c bucket_search_variance_sum_q48) to zero, resets sample counts to zero,
* and restores the min/max latency sentinels:
* - @c min_*_ns = @c INT64_MAX
* - @c max_*_ns = @c INT64_MIN
*
* Intended for DoE benchmark runs that need a clean statistical baseline
* between treatment cells. The parent @c HotwordsCache also holds the
* @c cache[] pointer array and LRU state; those are not touched — only the
* @c HotwordsStats sub-struct is cleared.
*
* @param stats Statistics structure to reset; no-op if NULL.
*/
void hotwords_stats_reset(HotwordsStats *stats) {
if (!stats) return;
/* Reset counters */
stats->total_lookups = 0;
stats->cache_hits = 0;
stats->bucket_hits = 0;
stats->misses = 0;
stats->evictions = 0;
stats->promotions = 0;
stats->bucket_reorders = 0;
/* Reset fixed-point accumulators */
stats->cache_hit_total_ns_q48 = 0;
stats->bucket_search_total_ns_q48 = 0;
stats->cache_hit_samples = 0;
stats->bucket_search_samples = 0;
/* Reset min/max latencies */
stats->min_cache_hit_ns = INT64_MAX;
stats->max_cache_hit_ns = INT64_MIN;
stats->min_bucket_search_ns = INT64_MAX;
stats->max_bucket_search_ns = INT64_MIN;
/* Reset variance accumulators */
stats->cache_hit_variance_sum_q48 = 0;
stats->bucket_search_variance_sum_q48 = 0;
}
/**
* @brief Print a formatted hot-words cache statistics report to @c stdout.
*
* Emits a Unicode box-drawing table covering three sections:
*
* **LOOKUPS** — total, cache hits, bucket hits, misses with percentages.
*
* **LATENCY STATISTICS** — for each of cache-hits and bucket-searches
* (when their sample counts are non-zero):
* - Min / avg / max in nanoseconds, derived from the Q48.16 accumulators
* by right-shifting 16 bits: @c avg_ns = @c total_ns_q48 / samples >> 16.
* - Standard deviation computed from the Welford-style variance accumulator:
* @c var = E[X²] − E[X]², then @c stddev = sqrt_q48(var), converted to
* nanoseconds via @c q48_to_ns_double() for display only.
* - Speedup ratio (bucket avg / cache avg) when both sample sets are present.
*
* **CACHE MANAGEMENT** — promotions, evictions, and bucket reorder counts.
*
* If @p stats is NULL or the total lookup count is zero, prints a brief
* "No lookups performed." notice instead of the full table. All floating-point
* usage in this function is display-only (via @c q48_to_ns_double()); the
* underlying accumulators remain in Q48.16 integer format.
*
* @param stats Statistics to report; no-op if NULL.
*/
void hotwords_stats_print(const HotwordsStats *stats) {
if (!stats) return;
printf("\n╔════════════════════════════════════════════════════════════════╗\n");
printf("║ Hot-Words Cache Statistics (64-bit Fixed-Point Q48.16) ║\n");
printf("╚════════════════════════════════════════════════════════════════╝\n\n");
uint64_t total = stats->cache_hits + stats->bucket_hits + stats->misses;
if (total == 0) {
printf("No lookups performed.\n");
return;
}
double cache_hit_pct = 100.0 * stats->cache_hits / total;
double bucket_hit_pct = 100.0 * stats->bucket_hits / total;
double miss_pct = 100.0 * stats->misses / total;
printf("LOOKUPS (Statistically Valid Sample Size):\n");
printf(" Total: %lu\n", total);
printf(" Cache hits: %lu (%.2f%%)\n", stats->cache_hits, cache_hit_pct);
printf(" Bucket hits: %lu (%.2f%%)\n", stats->bucket_hits, bucket_hit_pct);
printf(" Misses: %lu (%.2f%%)\n", stats->misses, miss_pct);
printf("\nLATENCY STATISTICS (64-bit Fixed-Point Precision):\n");
/* Cache hit latency (Q48.16 format: shift right by 16 bits to get nanoseconds) */
if (stats->cache_hit_samples > 0) {
int64_t avg_cache_ns_q48 = stats->cache_hit_total_ns_q48 / (int64_t)stats->cache_hit_samples;
double avg_cache_ns = (double)avg_cache_ns_q48 / 65536.0; /* Q48.16 to double */
double min_cache_ns = (double)stats->min_cache_hit_ns;
double max_cache_ns = (double)stats->max_cache_hit_ns;
printf(" Cache Hits (%lu samples):\n", stats->cache_hit_samples);
printf(" Min: %.3f ns\n", min_cache_ns);
printf(" Avg: %.3f ns\n", avg_cache_ns);
printf(" Max: %.3f ns\n", max_cache_ns);
/* Calculate variance and standard deviation */
int64_t variance_sum_q48 = stats->cache_hit_variance_sum_q48 / (int64_t)stats->cache_hit_samples;
int64_t mean_sq_q48 = (avg_cache_ns_q48 * avg_cache_ns_q48) / (1LL << 16);
int64_t var_q48 = variance_sum_q48 - mean_sq_q48;
int64_t stddev_q48 = (var_q48 >= 0) ? sqrt_q48(var_q48) : 0;
double stddev = q48_to_ns_double(stddev_q48);
printf(" StdDev: %.3f ns\n", stddev);
}
if (stats->bucket_search_samples > 0) {
int64_t avg_bucket_ns_q48 = stats->bucket_search_total_ns_q48 / (int64_t)stats->bucket_search_samples;
double avg_bucket_ns = (double)avg_bucket_ns_q48 / 65536.0; /* Q48.16 to double */
double min_bucket_ns = (double)stats->min_bucket_search_ns;
double max_bucket_ns = (double)stats->max_bucket_search_ns;
printf(" Bucket Searches (%lu samples):\n", stats->bucket_search_samples);
printf(" Min: %.3f ns\n", min_bucket_ns);
printf(" Avg: %.3f ns\n", avg_bucket_ns);
printf(" Max: %.3f ns\n", max_bucket_ns);
/* Calculate variance and standard deviation */
int64_t variance_sum_q48 = stats->bucket_search_variance_sum_q48 / (int64_t)stats->bucket_search_samples;
int64_t mean_sq_q48 = (avg_bucket_ns_q48 * avg_bucket_ns_q48) / (1LL << 16);
int64_t var_q48 = variance_sum_q48 - mean_sq_q48;
int64_t stddev_q48 = (var_q48 >= 0) ? sqrt_q48(var_q48) : 0;
double stddev = q48_to_ns_double(stddev_q48);
printf(" StdDev: %.3f ns\n", stddev);
/* Speedup calculation */
if (stats->cache_hit_samples > 0) {
int64_t avg_cache_ns_q48 = stats->cache_hit_total_ns_q48 / (int64_t)stats->cache_hit_samples;
double avg_bucket_ns_dbl = (double)avg_bucket_ns_q48 / 65536.0;
double speedup = avg_bucket_ns_dbl / ((double)avg_cache_ns_q48 / 65536.0);
printf(" Speedup: %.2f× (bucket vs cache)\n", speedup);
}
}
printf("\nCACHE MANAGEMENT:\n");
printf(" Promotions: %lu\n", stats->promotions);
printf(" Evictions: %lu\n", stats->evictions);
printf(" Reorders: %lu\n", stats->bucket_reorders);
printf("\n════════════════════════════════════════════════════════════════\n\n");
}
/**
* @brief Enable or disable the hot-words cache at runtime.
*
* Sets @c cache->enabled to @p enabled (non-zero = active, 0 = bypassed).
* When disabled, @c hotwords_cache_lookup() skips Stage 1 entirely and
* falls through directly to a bare bucket scan, recording no statistics.
* This allows benchmark harnesses to compare cache-on vs. cache-off behaviour
* without rebuilding the binary.
*
* @param cache Cache to configure; no-op if NULL.
* @param enabled Non-zero to enable the cache; 0 to disable.
*/
void hotwords_cache_set_enabled(HotwordsCache *cache, int enabled) {
if (!cache) return;
cache->enabled = enabled;
}
/* ============================================================================
* Bayesian Inference Implementation
* ============================================================================
*/
/**
* @brief Convert a Q48.16 fixed-point value to a @c double nanosecond count.
*
* Divides @p q48 by 65536.0 to recover the real-valued nanosecond count.
* This is the only floating-point operation in the module and is intentionally
* confined to display paths — @c hotwords_stats_print() and
* @c hotwords_bayesian_report() — so that all internal accumulation and
* statistical computation remains in Q48.16 integer arithmetic.
*
* @param q48 Value in Q48.16 format (1.0 ns = 65536).
* @return The same quantity as a @c double in nanoseconds.
*/
static inline double q48_to_ns_double(int64_t q48) {
return (double)q48 / 65536.0;
}
/**
* @brief Compute a Bayesian latency posterior for one measurement distribution.
*
* Given the accumulated Q48.16 statistics for a set of @p sample_count
* timing observations (either cache-hit or bucket-search latencies), computes
* the following posterior quantities entirely in Q48.16 integer arithmetic:
*
* - **Mean** (@c mean_ns_q48): @c total_ns_q48 / sample_count.
* - **Variance** (@c stddev_ns_q48): @c E[X²] − @c E[X]² where @c E[X²] is
* the per-sample average of @p variance_sum_q48 and @c E[X]² =
* @c mean² scaled to Q48.16 via @c >> 16. Variance is clamped to 0 to
* guard numerical rounding.
* - **Standard deviation** (@c stddev_ns_q48): @c sqrt_q48(variance).
* - **Median** (@c median_ns_q48): @c (min_ns + max_ns) / 2 — a quick
* midpoint estimate rather than a true median, consistent across all
* call sites.
* - **Standard error** (@c se_q48): @c stddev / √N, computed by converting
* @p sample_count to Q48.16 (@c sample_count << 16) and calling
* @c sqrt_q48(), then dividing @c stddev << 16 by the result.
* - **95% credible interval**: @c mean ± Z₉₅ × SE where
* @c Z₉₅ = 128431 (1.96 × 65536).
* - **99% credible interval**: @c mean ± Z₉₉ × SE where
* @c Z₉₉ = 168888 (2.576 × 65536).
* Lower credible bounds are clamped at 0 (latency is non-negative).
*
* Returns a zeroed @c BayesianLatencyPosterior if @p sample_count is 0.
*
* @param total_ns_q48 Sum of all latency observations in Q48.16.
* @param variance_sum_q48 Sum of squared latency observations in Q48.16
* (i.e., @c Σ(xᵢ² << 16)).
* @param min_ns Minimum observed latency in integer nanoseconds.
* @param max_ns Maximum observed latency in integer nanoseconds.
* @param sample_count Number of observations; 0 → returns zeroed struct.
* @return @c BayesianLatencyPosterior with all fields in Q48.16.
*/
static BayesianLatencyPosterior calculate_posterior(
int64_t total_ns_q48,
int64_t variance_sum_q48,
int64_t min_ns,
int64_t max_ns,
uint64_t sample_count) {
const int64_t Z95 = 128431LL; /* 1.96 * 65536 */
const int64_t Z99 = 168888LL; /* 2.576 * 65536 */
BayesianLatencyPosterior posterior = {0};
posterior.sample_count = sample_count;
if (sample_count == 0) {
return posterior;
}
/* Calculate mean from accumulated Q48.16 values (pure integer division) */
int64_t mean_q48 = total_ns_q48 / (int64_t)sample_count;
posterior.mean_ns_q48 = mean_q48;
/* Calculate variance: E[X^2] - E[X]^2, all in Q48.16 */
int64_t mean_sq_q48 = (mean_q48 * mean_q48) >> 16;
int64_t variance_sum_corrected = variance_sum_q48 / (int64_t)sample_count;
int64_t variance_q48 = variance_sum_corrected - mean_sq_q48;
if (variance_q48 < 0) variance_q48 = 0; /* Guard numerical errors */
/* Calculate standard deviation using Q48.16 sqrt */
int64_t stddev_q48 = sqrt_q48(variance_q48);
posterior.stddev_ns_q48 = stddev_q48;
/* Median: average of min/max */
posterior.median_ns_q48 = (min_ns + max_ns) / 2;
/* Standard error: stddev / sqrt(N) in Q48.16 */
/* sqrt(sample_count) approximation for Q48.16 arithmetic */
int64_t sqrt_n_q48 = sqrt_q48((int64_t)sample_count << 16); /* Convert N to Q48.16 */
int64_t se_q48 = (stddev_q48 << 16) / (sqrt_n_q48 >> 16); /* Careful division */
/* 95% credible interval: mean ± Z95 * SE (Z95 = 1.96 << 16) */
int64_t margin_95 = (Z95 * se_q48) >> 16;
posterior.credible_lower_95 = mean_q48 - margin_95;
posterior.credible_upper_95 = mean_q48 + margin_95;
/* 99% credible interval: mean ± Z99 * SE (Z99 = 2.576 << 16) */
int64_t margin_99 = (Z99 * se_q48) >> 16;
posterior.credible_lower_99 = mean_q48 - margin_99;
posterior.credible_upper_99 = mean_q48 + margin_99;
/* Clamp lower bounds to >= 0 */
if (posterior.credible_lower_95 < 0) posterior.credible_lower_95 = 0;
if (posterior.credible_lower_99 < 0) posterior.credible_lower_99 = 0;
return posterior;
}
/**
* @brief Return the Bayesian latency posterior for cache-hit observations.
*
* Forwards the cache-hit accumulators from @p stats to @c calculate_posterior():
* @c cache_hit_total_ns_q48, @c cache_hit_variance_sum_q48, @c min_cache_hit_ns,
* @c max_cache_hit_ns, and @c cache_hit_samples. Returns a zeroed
* @c BayesianLatencyPosterior if @p stats is NULL or no cache-hit samples have
* been recorded yet.
*
* The returned posterior's @c mean_ns_q48, @c stddev_ns_q48, and 95%/99%
* credible-interval fields are consumed by @c hotwords_speedup_estimate() and
* @c hotwords_bayesian_report() to compare cache-hit latency against bucket-search
* latency.
*
* @param stats @c HotwordsStats containing cache-hit timing accumulators.
* @return Posterior in Q48.16; all fields zero if no samples exist.
*/
BayesianLatencyPosterior hotwords_posterior_cache_hits(const HotwordsStats *stats) {
if (!stats || stats->cache_hit_samples == 0) {
BayesianLatencyPosterior empty = {0};
return empty;
}
return calculate_posterior(
stats->cache_hit_total_ns_q48,
stats->cache_hit_variance_sum_q48,
stats->min_cache_hit_ns,
stats->max_cache_hit_ns,
stats->cache_hit_samples
);
}
/**
* @brief Return the Bayesian latency posterior for bucket-search observations.
*
* Forwards the bucket-search accumulators from @p stats to @c calculate_posterior():
* @c bucket_search_total_ns_q48, @c bucket_search_variance_sum_q48,
* @c min_bucket_search_ns, @c max_bucket_search_ns, and @c bucket_search_samples.
* Returns a zeroed @c BayesianLatencyPosterior if @p stats is NULL or no
* bucket-search samples have been recorded.
*
* The returned posterior's mean and credible-interval fields feed
* @c hotwords_speedup_estimate() (as the slower distribution) and the
* baseline section of @c hotwords_bayesian_report().
*
* @param stats @c HotwordsStats containing bucket-search timing accumulators.
* @return Posterior in Q48.16; all fields zero if no samples exist.
*/
BayesianLatencyPosterior hotwords_posterior_bucket_searches(const HotwordsStats *stats) {
if (!stats || stats->bucket_search_samples == 0) {
BayesianLatencyPosterior empty = {0};
return empty;
}
return calculate_posterior(
stats->bucket_search_total_ns_q48,
stats->bucket_search_variance_sum_q48,
stats->min_bucket_search_ns,
stats->max_bucket_search_ns,
stats->bucket_search_samples
);
}
/**
* @brief Compute a speedup estimate with credible intervals using the delta method.
*
* Derives a dimensionless speedup ratio @c S = bucket_mean / cache_mean in
* Q48.16 fixed-point and propagates uncertainty via the delta method for ratios:
* @code
* SE(S) ≈ S × sqrt( (SE_bucket / bucket_mean)² + (SE_cache / cache_mean)² )
* @endcode
* All arithmetic is Q48.16 integer throughout; the only deviation is the
* intermediate @c sqrt() call which also runs in Q48.16 via @c sqrt_q48().
*
* Computed fields in the returned @c SpeedupEstimate (all Q48.16):
* - @c speedup_factor_q48 — point estimate of @c S.
* - @c credible_lower_95_q48 / @c credible_upper_95_q48 — 95% credible
* interval: @c S ± 1.96 × SE(S) (Z₉₅ = 128431 in Q48.16). Lower bound
* clamped at 0.
* - @c probability_gt_10pct_q48 — P(speedup > 1.1×), computed as
* @c 0.5 × (1 + erf(z / √2)) where @c z = (1.1 − S) / SE(S) is negated
* to give the right-tail probability and @c √2 = 92681 in Q48.16.
* - @c probability_gt_double_q48 — P(speedup > 2.0×), same formula with
* target = 2.0 × 65536 = 131072.
*
* Returns a default @c SpeedupEstimate with @c speedup_factor_q48 = 65536
* (1.0×) if either distribution has zero samples or if @p stats is NULL.
*
* @param stats @c HotwordsStats with both cache-hit and bucket-search samples.
* @return @c SpeedupEstimate with all fields in Q48.16 fixed-point.
*/
struct SpeedupEstimate hotwords_speedup_estimate(const HotwordsStats *stats) {
const int64_t Q48 = 65536LL;
const int64_t SQRT2 = 92681LL; /* sqrt(2) * 65536 ≈ 1.414 * 65536 */
struct SpeedupEstimate est = {0};
if (!stats || stats->cache_hit_samples == 0 || stats->bucket_search_samples == 0) {
est.speedup_factor_q48 = Q48; /* Default: 1.0x speedup */
return est;
}
BayesianLatencyPosterior cache_post = hotwords_posterior_cache_hits(stats);
BayesianLatencyPosterior bucket_post = hotwords_posterior_bucket_searches(stats);
/* Guard divide-by-zero */
if (cache_post.mean_ns_q48 < 1) cache_post.mean_ns_q48 = 1;
/* Point estimate: speedup = bucket_time / cache_time (dimensionless, in Q48.16) */
int64_t speedup_q48 = (bucket_post.mean_ns_q48 << 16) / cache_post.mean_ns_q48;
est.speedup_factor_q48 = speedup_q48;
/* Delta-method SE for ratio: SE(speedup) ≈ speedup * sqrt((SE_bucket/bucket)^2 + (SE_cache/cache)^2) */
int64_t se_cache_q48 = (cache_post.stddev_ns_q48 << 16) / (int64_t)stats->cache_hit_samples;
int64_t se_bucket_q48 = (bucket_post.stddev_ns_q48 << 16) / (int64_t)stats->bucket_search_samples;
/* Relative standard errors: SE/mean */
int64_t rel_se_cache_q48 = (se_cache_q48 << 16) / cache_post.mean_ns_q48;
int64_t rel_se_bucket_q48 = (se_bucket_q48 << 16) / bucket_post.mean_ns_q48;
/* Combine: sqrt((rel_se_cache)^2 + (rel_se_bucket)^2) */
int64_t sum_sq = ((rel_se_cache_q48 * rel_se_cache_q48) >> 16) +
((rel_se_bucket_q48 * rel_se_bucket_q48) >> 16);
int64_t rel_se_ratio_q48 = sqrt_q48(sum_sq);
/* SE(speedup) = speedup * rel_se_ratio */
int64_t se_speedup_q48 = (speedup_q48 * rel_se_ratio_q48) >> 16;
/* 95% credible interval for speedup (Z1.96 = 128431 in Q48.16) */
int64_t margin_95_q48 = (128431LL * se_speedup_q48) >> 16;
est.credible_lower_95_q48 = speedup_q48 - margin_95_q48;
est.credible_upper_95_q48 = speedup_q48 + margin_95_q48;
if (est.credible_lower_95_q48 < 0) est.credible_lower_95_q48 = 0;
/* Probability of speedup > 1.1× using erf_q48 (pure fixed-point) */
/* Z-score: (1.1 - speedup) / SE_speedup, computed in Q48.16 */
/* Result: erf returns Q48.16 in [-65536, 65536], convert to probability [0, 65536] */
int64_t target_110_q48 = 72090LL; /* 1.1 * 65536 */
int64_t z_10pct_q48 = ((target_110_q48 - speedup_q48) << 16) / se_speedup_q48;
int64_t erf_val_10pct = erf_q48((-z_10pct_q48) / SQRT2);
/* Convert erf result to probability: P = 0.5 * (1 + erf) in Q48.16 */
est.probability_gt_10pct_q48 = (Q48 + erf_val_10pct) >> 1;
/* Probability of speedup > 2.0× */
int64_t target_200_q48 = 131072LL; /* 2.0 * 65536 */
int64_t z_2x_q48 = ((target_200_q48 - speedup_q48) << 16) / se_speedup_q48;
int64_t erf_val_2x = erf_q48((-z_2x_q48) / SQRT2);
est.probability_gt_double_q48 = (Q48 + erf_val_2x) >> 1;
return est;
}
/**
* @brief Print a full Bayesian cache performance report comparing two experimental conditions.
*
* Emits a structured Unicode report to @c stdout comparing the latency
* distributions of two measurement sets — one collected with the hot-words
* cache enabled, the other collected without (baseline). The report is divided
* into five sections:
*
* 1. **WITH CACHE ENABLED** — posterior mean, stddev, and 95%/99% credible
* intervals for cache-hits and bucket-searches separately, via
* @c hotwords_posterior_cache_hits() and @c hotwords_posterior_bucket_searches().
*
* 2. **WITHOUT CACHE (Baseline)** — posterior mean, stddev, and 95% credible
* interval for all lookups (treated as bucket searches). If no bucket data
* is available in @p stats_without_cache, the bucket-search mean from the
* with-cache run is used as an approximation.
*
* 3. **SPEEDUP ESTIMATE (Bucket vs Cache)** — @c hotwords_speedup_estimate()
* point estimate, 95% credible interval, P(>1.1×), and P(>2.0×).
*
* 4. **CACHE EFFECTIVENESS** — total lookups, cache-hit rate, bucket-hit rate,
* and miss rate as percentages of total.
*
* 5. **OVERALL PERFORMANCE** — weighted-average latency with cache vs. baseline
* all-bucket latency, overall speedup, and absolute time saved per lookup.
* The weighted average is: @c (N_cache×avg_cache + N_bucket×avg_bucket) /
* @c (N_cache + N_bucket).
*
* All latency values are displayed in nanoseconds (floating-point via
* @c q48_to_ns_double()) for readability; underlying accumulators are Q48.16
* integer throughout.
*
* No-op if either @p stats_with_cache or @p stats_without_cache is NULL.
*
* @param stats_with_cache Statistics from a run with cache enabled.
* @param stats_without_cache Statistics from a baseline run without cache.
*/
void hotwords_bayesian_report(const HotwordsStats *stats_with_cache,
const HotwordsStats *stats_without_cache) {
if (!stats_with_cache || !stats_without_cache) return;
printf("\n╔════════════════════════════════════════════════════════════════╗\n");
printf("║ Bayesian Performance Analysis: Cache Impact ║\n");
printf("╚════════════════════════════════════════════════════════════════╝\n\n");
/* WITH CACHE statistics */
BayesianLatencyPosterior cache_with = hotwords_posterior_cache_hits(stats_with_cache);
BayesianLatencyPosterior bucket_with = hotwords_posterior_bucket_searches(stats_with_cache);
printf("WITH CACHE ENABLED:\n");
printf("─────────────────────────────────────────────────────────────────\n");
printf("Cache Hits (N=%lu):\n", cache_with.sample_count);
printf(" Mean: %.2f ns\n", q48_to_ns_double(cache_with.mean_ns_q48));
printf(" Std Dev: %.2f ns\n", q48_to_ns_double(cache_with.stddev_ns_q48));
printf(" 95%% Credible: [%.2f, %.2f] ns\n", q48_to_ns_double(cache_with.credible_lower_95), q48_to_ns_double(cache_with.credible_upper_95));
printf(" 99%% Credible: [%.2f, %.2f] ns\n\n", q48_to_ns_double(cache_with.credible_lower_99), q48_to_ns_double(cache_with.credible_upper_99));
printf("Bucket Searches (N=%lu):\n", bucket_with.sample_count);
printf(" Mean: %.2f ns\n", q48_to_ns_double(bucket_with.mean_ns_q48));
printf(" Std Dev: %.2f ns\n", q48_to_ns_double(bucket_with.stddev_ns_q48));
printf(" 95%% Credible: [%.2f, %.2f] ns\n", q48_to_ns_double(bucket_with.credible_lower_95), q48_to_ns_double(bucket_with.credible_upper_95));
printf(" 99%% Credible: [%.2f, %.2f] ns\n\n", q48_to_ns_double(bucket_with.credible_lower_99), q48_to_ns_double(bucket_with.credible_upper_99));
/* WITHOUT CACHE statistics */
printf("WITHOUT CACHE (Baseline):\n");
printf("─────────────────────────────────────────────────────────────────\n");
printf("All Lookups (N=%lu):\n", stats_without_cache->cache_hits + stats_without_cache->bucket_hits);
/* Estimate average latency without cache (all go to bucket) */
BayesianLatencyPosterior all_lookups_baseline = hotwords_posterior_bucket_searches(stats_without_cache);
if (all_lookups_baseline.sample_count == 0) {
/* Fallback if bucket data not available */
all_lookups_baseline.mean_ns_q48 = bucket_with.mean_ns_q48;
}
printf(" Mean: %.2f ns\n", q48_to_ns_double(all_lookups_baseline.mean_ns_q48));
printf(" Std Dev: %.2f ns\n", q48_to_ns_double(all_lookups_baseline.stddev_ns_q48));
printf(" 95%% Credible: [%.2f, %.2f] ns\n\n", q48_to_ns_double(all_lookups_baseline.credible_lower_95), q48_to_ns_double(all_lookups_baseline.credible_upper_95));
/* Speedup Analysis */
struct SpeedupEstimate speedup = hotwords_speedup_estimate(stats_with_cache);
printf("SPEEDUP ESTIMATE (Bucket vs Cache):\n");
printf("─────────────────────────────────────────────────────────────────\n");
printf(" Point Estimate: %.2f×\n", q48_to_ns_double(speedup.speedup_factor_q48));
printf(" 95%% Credible Interval: [%.2f×, %.2f×]\n", q48_to_ns_double(speedup.credible_lower_95_q48), q48_to_ns_double(speedup.credible_upper_95_q48));
printf(" P(Speedup > 1.1×): %.1f%% (credible improvement exists)\n", q48_to_ns_double(speedup.probability_gt_10pct_q48) * 100.0);
printf(" P(Speedup > 2.0×): %.1f%% (significant speedup)\n\n", q48_to_ns_double(speedup.probability_gt_double_q48) * 100.0);
/* Hit Rate Analysis */
uint64_t total_lookups_with = stats_with_cache->cache_hits + stats_with_cache->bucket_hits + stats_with_cache->misses;
double cache_hit_rate = (total_lookups_with > 0) ? (100.0 * stats_with_cache->cache_hits / total_lookups_with) : 0.0;
printf("CACHE EFFECTIVENESS:\n");
printf("─────────────────────────────────────────────────────────────────\n");
printf(" Total Lookups: %lu\n", total_lookups_with);
printf(" Cache Hits: %lu (%.1f%%)\n", stats_with_cache->cache_hits, cache_hit_rate);
printf(" Bucket Hits: %lu (%.1f%%)\n", stats_with_cache->bucket_hits,
100.0 * stats_with_cache->bucket_hits / total_lookups_with);
printf(" Misses: %lu (%.1f%%)\n\n", stats_with_cache->misses,
100.0 * stats_with_cache->misses / total_lookups_with);
/* Overall Performance */
double mixed_avg_latency = ((double)stats_with_cache->cache_hits * q48_to_ns_double(cache_with.mean_ns_q48) +
(double)stats_with_cache->bucket_hits * q48_to_ns_double(bucket_with.mean_ns_q48)) /
(stats_with_cache->cache_hits + stats_with_cache->bucket_hits);
double baseline_avg_latency = q48_to_ns_double(all_lookups_baseline.mean_ns_q48);
double overall_speedup = baseline_avg_latency / mixed_avg_latency;
printf("OVERALL PERFORMANCE (WITH vs WITHOUT CACHE):\n");
printf("─────────────────────────────────────────────────────────────────\n");
printf(" Baseline (all bucket): %.2f ns/lookup\n", baseline_avg_latency);
printf(" With cache: %.2f ns/lookup\n", mixed_avg_latency);
printf(" Overall Speedup: %.2f×\n", overall_speedup);
printf(" Time Saved per Lookup: %.2f ns (%.1f%%)\n\n", baseline_avg_latency - mixed_avg_latency,
100.0 * (baseline_avg_latency - mixed_avg_latency) / baseline_avg_latency);
printf("╚════════════════════════════════════════════════════════════════╝\n\n");
}
v3/src/physics_metadata.c
+387
View File
@@ -0,0 +1,387 @@
/*
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.
*/
/*
*** StarForth ***
physics_metadata.c - Phase 1 physics metadata helpers
Captures thermodynamic-style signals for dictionary entries without
introducing heavy runtime cost. Future phases can build on these helpers
to drive physics-aware scheduling and storage placement.
*/
#include "../include/physics_metadata.h"
#include "../include/ssm_jacquard.h"
#include <stddef.h>
#include <stdint.h>
#include <string.h>
/* L8 FINAL INTEGRATION: L1 heat tracking is always-on (internal physics signal) */
/**
* @brief Clamp a uint64_t value to the uint32_t range.
*
* @param value Input value to clamp
* @return @c UINT32_MAX if @c value > UINT32_MAX, else @c (uint32_t)value
*/
static uint32_t clamp_u32(uint64_t value) {
return (value > UINT32_MAX) ? UINT32_MAX : (uint32_t) value;
}
/**
* @brief Derive a smoothed Q8 temperature from raw execution heat.
*
* Converts @c execution_heat to Q8 by left-shifting 8 bits, clamps to
* UINT16_MAX, then applies a 1/4 EMA blend with @c prior_q8 to suppress
* jitter: result = (3*prior + target) / 4. Returns 0 for non-positive heat.
*
* @param execution_heat Raw execution heat counter for the word
* @param prior_q8 Previous smoothed temperature in Q8 format
* @return Updated smoothed temperature in Q8 format
*/
static uint16_t temperature_from_execution_heat(cell_t execution_heat, uint16_t prior_q8) {
if (execution_heat <= 0) return 0;
uint64_t scaled = ((uint64_t) execution_heat) << 8; /* convert to Q8 */
uint16_t target = (scaled > UINT16_MAX) ? UINT16_MAX : (uint16_t) scaled;
/* Smooth with a simple EMA to avoid jitter */
return (uint16_t)((3u * prior_q8 + target) / 4u);
}
/**
* @brief Derive the physics state flags bitmask from a DictEntry's word flags.
*
* Maps @c WORD_IMMEDIATE → @c PHYSICS_STATE_IMMEDIATE,
* @c WORD_PINNED → @c PHYSICS_STATE_PINNED,
* @c WORD_HIDDEN → @c PHYSICS_STATE_HIDDEN, and
* @c WORD_COMPILED → @c PHYSICS_STATE_COMPILED.
*
* @param entry DictEntry to inspect (NULL returns 0)
* @return Bitmask of @c PHYSICS_STATE_* flags
*/
static uint8_t derive_state_flags(const DictEntry *entry) {
if (!entry) return 0;
uint8_t flags = 0;
if (entry->flags & WORD_IMMEDIATE) flags |= PHYSICS_STATE_IMMEDIATE;
if (entry->flags & WORD_PINNED) flags |= PHYSICS_STATE_PINNED;
if (entry->flags & WORD_HIDDEN) flags |= PHYSICS_STATE_HIDDEN;
if (entry->flags & WORD_COMPILED) flags |= PHYSICS_STATE_COMPILED;
return flags;
}
/**
* @brief Initialise physics metadata for a newly registered DictEntry.
*
* Zeroes all @c DictPhysics fields, sets @c mass_bytes to @c header_bytes
* (the byte size of the entry header), and derives initial @c state_flags
* from the entry's word flags. Called from @c register_word() immediately
* after the entry is linked into the dictionary.
*
* @param entry DictEntry to initialise
* @param header_bytes Byte size of the entry's header region (for mass)
*/
void physics_metadata_init(DictEntry *entry, uint32_t header_bytes) {
if (!entry) return;
entry->physics.temperature_q8 = 0;
entry->physics.last_active_ns = 0;
entry->physics.last_decay_ns = 0;
entry->physics.last_decay_tick = 0;
entry->physics.mass_bytes = header_bytes;
entry->physics.avg_latency_ns = 0;
entry->physics.state_flags = derive_state_flags(entry);
entry->physics.acl_hint = 0;
entry->physics.pubsub_mask = 0;
}
/**
* @brief Update the mass (byte footprint) of a DictEntry's physics metadata.
*
* Called after a colon definition or CREATE body is fully compiled so the
* mass reflects the total compiled size, not just the header.
*
* @param entry DictEntry to update
* @param total_bytes Total compiled byte size (header + body)
*/
void physics_metadata_set_mass(DictEntry *entry, uint32_t total_bytes) {
if (!entry) return;
entry->physics.mass_bytes = total_bytes;
}
/* ============================================================================
* INTENT: Update word's physics metadata after execution
* FL1: Heat accumulation feedback loop - converts raw execution_heat counter
* to smoothed temperature_q8 metric and updates activity timestamps
* WHY: Atomic heat increment (FL1) happens in execution loop; this function
* derives secondary metrics (temperature, timestamps) for observability
* ============================================================================ */
/**
* @brief Update physics metadata after a word execution completes.
*
* Derives and stores a new smoothed @c temperature_q8 from @c execution_heat,
* and updates both @c last_active_ns and @c last_decay_ns to @c now_ns.
* Called by @c physics_post_execute() on the post-execution path.
*
* @param entry DictEntry that was just executed
* @param execution_heat Current raw execution heat counter
* @param now_ns Current monotonic timestamp in nanoseconds
*/
void physics_metadata_touch(DictEntry *entry, cell_t execution_heat, uint64_t now_ns) {
if (!entry) return;
entry->physics.temperature_q8 = temperature_from_execution_heat(execution_heat, entry->physics.temperature_q8);
entry->physics.last_active_ns = now_ns;
entry->physics.last_decay_ns = now_ns;
}
/**
* @brief Re-derive and update @c state_flags for a DictEntry.
*
* Called after word flags change (e.g. IMMEDIATE is set during compilation)
* to keep the physics state flags in sync with the word flags.
*
* @param entry DictEntry whose state flags are to be refreshed
*/
void physics_metadata_refresh_state(DictEntry *entry) {
if (!entry) return;
entry->physics.state_flags = derive_state_flags(entry);
}
/**
* @brief Record an execution latency sample into the per-word EMA.
*
* Clamps @c sample_ns to uint32_t, then blends it into @c avg_latency_ns
* with a 1/4 EMA: new = (3*prior + sample) / 4. Seeds @c avg_latency_ns
* directly from the first sample.
*
* @param entry DictEntry whose latency EMA is updated
* @param sample_ns Measured execution duration in nanoseconds
*/
void physics_metadata_record_latency(DictEntry *entry, uint64_t sample_ns) {
if (!entry) return;
uint32_t sample = clamp_u32(sample_ns);
uint32_t prior = entry->physics.avg_latency_ns;
if (prior == 0) {
entry->physics.avg_latency_ns = sample;
} else {
entry->physics.avg_latency_ns = (uint32_t)((3ull * prior + sample) / 4ull);
}
}
typedef struct physics_seed_definition {
const char *name;
uint16_t temperature_q8;
uint32_t avg_latency_ns;
uint8_t acl_hint;
uint8_t pubsub_mask;
} physics_seed_definition_t;
static const physics_seed_definition_t physics_seed_table[] = {
{"IF", 0x0100u, 400u, 0, 0},
{"ELSE", 0x0100u, 400u, 0, 0},
{"THEN", 0x0100u, 350u, 0, 0},
{"BEGIN", 0x0120u, 450u, 0, 0},
{"WHILE", 0x0120u, 450u, 0, 0},
{"REPEAT", 0x0120u, 450u, 0, 0},
{"DO", 0x0180u, 500u, 0, 0},
{"LOOP", 0x0180u, 500u, 0, 0},
{"+LOOP", 0x0200u, 520u, 0, 0},
{"LEAVE", 0x0200u, 520u, 0, 0},
{".", 0x0080u, 300u, 0, 0},
{"EMIT", 0x0180u, 800u, 0, 0x02u},
{"TYPE", 0x0180u, 900u, 0, 0x02u},
{"BLOCK", 0x0200u, 950u, 0, 0x04u},
{"BUFFER", 0x01C0u, 900u, 0, 0x04u},
{"SAVE-BUFFERS", 0x0260u, 1400u, 0, 0x04u},
{"FLUSH", 0x0240u, 1200u, 0, 0x04u},
{"LOAD", 0x0220u, 1100u, 0, 0x04u},
{"LIST", 0x0200u, 1000u, 0, 0x04u},
{"SAVE-SYSTEM", 0x0280u, 2000u, 0x80u, 0x08u},
{NULL, 0, 0, 0, 0}
};
/**
* @brief Apply DoE-derived prior physics values to a named DictEntry.
*
* Searches the static @c physics_seed_table for an entry matching
* @c entry->name. If found, seeds @c temperature_q8, @c avg_latency_ns,
* @c acl_hint, and @c pubsub_mask with values derived from the 2^7
* factorial DoE analysis. Only non-zero seed fields overwrite the current
* value. Called from @c register_word() for built-in primitives.
*
* @param entry DictEntry to seed (no-op if NULL or no matching table entry)
*/
void physics_metadata_apply_seed(DictEntry *entry) {
if (!entry || !entry->name_len) return;
for (const physics_seed_definition_t *seed = physics_seed_table; seed->name; ++seed) {
if ((int) strlen(seed->name) != entry->name_len) continue;
if (strncmp(seed->name, entry->name, entry->name_len) != 0) continue;
if (seed->temperature_q8) entry->physics.temperature_q8 = seed->temperature_q8;
if (seed->avg_latency_ns) entry->physics.avg_latency_ns = seed->avg_latency_ns;
if (seed->acl_hint) entry->physics.acl_hint = seed->acl_hint;
if (seed->pubsub_mask) entry->physics.pubsub_mask = seed->pubsub_mask;
break;
}
}
/*
* ============================================================================
* Phase 2: Linear Decay Mechanism
* ============================================================================
*
* Reduces execution_heat over time to model:
* - OS context switches (old task's heat becomes stale)
* - Temporal locality (recent access patterns > distant past)
* - Dissipation (physical analogy: thermal equilibrium)
*
* Mathematical Model (Discrete Linear):
* H(t) = max(0, H_0 - d*t)
*
* Where:
* H(t) = heat at time t
* H_0 = initial heat
* d = decay rate (heat units per heartbeat tick)
* t = heartbeat ticks elapsed since last execution -- never wall-clock
* time; see physics_metadata_apply_linear_decay()'s doc comment
*
* Frozen words (WORD_FROZEN flag) are exempt from decay.
* ============================================================================
*/
/**
* @brief Apply Loop #3 linear heat decay to a DictEntry.
*
* Implements the thermodynamic dissipation model: H(t) = max(0, H₀ - d*t),
* where t is measured in heartbeat ticks (@c vm->heartbeat.tick_count),
* never in wall-clock time. The decay amount is computed as
* (elapsed_ticks * slope_q48) >> 16 using the Q48.16 adaptive decay slope
* stored in the VM's heartbeat state. Uses a GCC CAS loop for atomic heat
* update when @c __GNUC__ is defined, falling back to a plain subtraction
* otherwise.
*
* Ticks, not nanoseconds: this entry's @c execution_heat feeds directly
* into @c dict_hash (see @c capsule_dict_hash_hook()), so any wall-clock
* dependency here makes dictionary state -- and therefore dict_hash --
* architecture-variable under QEMU/TCG's differing real emulation speed,
* or whenever real elapsed time between two touches of the same entry
* varies for reasons unrelated to execution (e.g. a blocking I/O wait
* between them). @c vm->heartbeat.tick_count only advances from
* @c vm_tick(), called synchronously from the interpreter's own dispatch
* path -- a purely execution-count-driven clock, immune to how long any
* intervening real-time work (including blocking I/O) actually took.
*
* No-op when:
* - @c WORD_FROZEN flag is set on the entry
* - @c elapsed_ticks == 0 (no heartbeat tick has fired since last decay)
* - @c vm->ssm_config has L3 disabled by the Jacquard mode selector
*
* @param entry DictEntry whose heat is decayed
* @param elapsed_ticks Heartbeat ticks elapsed since last decay application
* @param vm VM providing the adaptive decay slope and L3 gate flag
*/
void physics_metadata_apply_linear_decay(DictEntry *entry, uint64_t elapsed_ticks, VM *vm) {
if (!entry || !vm) {
return;
}
/* Frozen words do not decay */
if (entry->flags & WORD_FROZEN) {
return;
}
/* Don't bother when no tick has fired since the last application */
if (elapsed_ticks == 0) {
return;
}
/* L8 GATE: Check if L3 (linear decay) is enabled by Jacquard mode selector */
if (vm->ssm_config) {
ssm_config_t *config = (ssm_config_t*)vm->ssm_config;
if (!config->L3_linear_decay) {
return; /* L3 disabled by L8 mode selector */
}
}
/* ========================================================================
* INTENT: Calculate decay amount using adaptive Q48.16 fixed-point math
* FL1: Heat decay - counterbalances FL1 accumulation to prevent runaway
* FL3: Adaptive slope tuning - inference engine adjusts decay_slope_q48
* based on statistical analysis of heat trajectory effectiveness
* WHY: decay_slope_q48 is expressed as heat units per tick, not per
* microsecond -- the inference engine (Loop #6) adaptively
* calibrates it against whatever units it's actually applied in,
* so no conversion constant is needed here, just a consistent unit.
* ======================================================================== */
uint64_t slope_q48 = physics_decay_slope_load(vm);
uint64_t decay_amount_raw = (elapsed_ticks * slope_q48) >> 16;
/* Clamp to cell_t range (avoid overflow) */
cell_t decay_amount = (decay_amount_raw > (uint64_t)0x7FFFFFFFFFFFFFFF)
? 0x7FFFFFFFFFFFFFFF
: (cell_t)decay_amount_raw;
if (decay_amount == 0) {
return;
}
#if defined(__GNUC__)
cell_t old_heat;
cell_t new_heat;
do {
old_heat = __atomic_load_n(&entry->execution_heat, __ATOMIC_RELAXED);
if (old_heat == 0) {
return;
}
new_heat = (decay_amount >= old_heat) ? 0 : (old_heat - decay_amount);
} while (!__atomic_compare_exchange_n(&entry->execution_heat,
&old_heat,
new_heat,
0,
__ATOMIC_RELAXED,
__ATOMIC_RELAXED));
#else
if (decay_amount >= entry->execution_heat) {
entry->execution_heat = 0;
} else {
entry->execution_heat -= decay_amount;
}
#endif
}
v3/src/physics_pipelining_metrics.c
+754
View File
@@ -0,0 +1,754 @@
/*
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.
*/
/*
*** StarForth ***
physics_pipelining_metrics.c - Word transition tracking implementation
Tracks word-to-word transitions to support speculative execution/pipelining.
Uses only fixed-point Q48.16 arithmetic (no floating-point).
*/
#include "physics_pipelining_metrics.h"
#include "vm.h"
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
/* ============================================================================
* Q48.16 Fixed-Point Arithmetic Helpers
* ============================================================================
*/
/**
* @brief Convert a nanosecond count to Q48.16 fixed-point.
*
* Shifts @p ns left by 16 bits to produce a Q48.16 value where the integer
* part represents nanoseconds (1.0 ns = 65536 in Q48.16). Used to convert
* raw platform nanosecond timestamps into the common Q48.16 format before
* accumulating into @c prefetch_latency_saved_q48 and
* @c misprediction_cost_q48.
*
* @param ns Integer nanosecond value to convert.
* @return @p ns in Q48.16 format (@p ns × 65536).
*/
static inline int64_t ns_to_q48(int64_t ns) {
return ns << 16;
}
/**
* @brief Convert a Q48.16 fixed-point value to integer nanoseconds (truncated).
*
* Shifts @p q48 right by 16 bits, discarding the fractional part. The result
* is the integer nanosecond count represented by the Q48.16 value. Used in
* @c transition_metrics_stats_string() to convert the accumulated
* @c prefetch_latency_saved_q48 and @c misprediction_cost_q48 back to
* human-readable nanosecond integers for the stats report string.
*
* @param q48 Value in Q48.16 format.
* @return Integer nanosecond equivalent (truncated, not rounded).
*/
static inline int64_t q48_to_ns(int64_t q48) {
return q48 >> 16;
}
/**
* @brief Divide a Q48.16 value by a @c uint64_t, returning Q48.16.
*
* Computes @p a_q48 / @p b using integer division. The result preserves the
* Q48.16 scaling of @p a_q48 because @p b is dimensionless. Guards against
* divide-by-zero by returning 0 when @p b == 0. Used by
* @c transition_metrics_get_probability_q48() to compute the per-word
* transition probability:
* @code
* P(next = w) = (count_q48 << 16) / total_transitions
* @endcode
* where @c count_q48 = (uint64_t)count << 16 and @c total_transitions is the
* denominator @p b.
*
* @param a_q48 Numerator in Q48.16 format.
* @param b Denominator as a plain @c uint64_t (dimensionless count).
* @return @p a_q48 / @p b in Q48.16; 0 if @p b == 0.
*/
static inline int64_t q48_div_u64(int64_t a_q48, uint64_t b) {
if (b == 0) return 0;
return a_q48 / (int64_t)b;
}
/* ============================================================================
* Transition Metrics Implementation
* ============================================================================
*/
/**
* @brief Initialise a @c WordTransitionMetrics structure to its empty, ready-to-record state.
*
* Sets all counter and accumulator fields to zero and performs the following
* allocations:
*
* - @c metrics->transition_heat is left NULL — it is lazily allocated by the
* first call to @c transition_metrics_record() to avoid the @c dict_size
* parameter being required at construction time.
*
* - If @c TRANSITION_WINDOW_SIZE > 0, allocates @c metrics->context_window as
* a zero-filled array of @c TRANSITION_WINDOW_SIZE @c uint32_t word IDs and
* sets @c metrics->actual_window_size accordingly. If the allocation fails,
* @c actual_window_size is set to 0 and context tracking degrades gracefully
* (all context functions become no-ops).
*
* - @c metrics->context_transitions is left NULL — it is lazily allocated when
* Phase 2 context-pattern analysis is implemented.
*
* Returns 0 on success or −1 if @p metrics is NULL.
*
* @param metrics The @c WordTransitionMetrics to initialise; must not be NULL.
* @return 0 on success; −1 if @p metrics is NULL.
*/
int transition_metrics_init(WordTransitionMetrics *metrics) {
if (!metrics) return -1;
metrics->transition_heat = NULL; /* Lazy allocation on first use */
metrics->total_transitions = 0;
metrics->prefetch_attempts = 0;
metrics->prefetch_hits = 0;
metrics->prefetch_misses = 0;
metrics->prefetch_latency_saved_q48 = 0;
metrics->misprediction_cost_q48 = 0;
metrics->max_transition_probability_q48 = 0;
metrics->most_likely_next_word_id = 0;
/* Phase 1 Extension: Initialize context window (window size = 2 by default) */
if (TRANSITION_WINDOW_SIZE > 0) {
metrics->context_window = (uint32_t *)calloc(TRANSITION_WINDOW_SIZE, sizeof(uint32_t));
if (metrics->context_window) {
metrics->actual_window_size = TRANSITION_WINDOW_SIZE;
metrics->context_window_pos = 0;
} else {
metrics->actual_window_size = 0; /* Degraded: no context tracking */
}
} else {
metrics->actual_window_size = 0;
}
metrics->context_transitions = NULL; /* Lazy allocation on first context transition */
metrics->total_context_transitions = 0;
return 0;
}
/**
* @brief Record one word-to-word transition in the transition heat table.
*
* Called from the interpreter loop each time a word executes and there is a
* known previous word. Increments @c metrics->transition_heat[next_word_id]
* by one and @c metrics->total_transitions by one.
*
* **Lazy allocation:** The @c transition_heat array is not allocated at
* @c transition_metrics_init() time; on the first call when
* @c metrics->transition_heat == NULL, it is allocated as a zero-filled
* array of @p dict_size @c uint64_t counters. If the allocation fails −1 is
* returned and the transition is silently dropped.
*
* If @p next_word_id ≥ @p dict_size the call is rejected with −1 to prevent
* an out-of-bounds write into @c transition_heat (which was allocated with
* size @p dict_size).
*
* The accumulated @c transition_heat[] table is consumed by
* @c transition_metrics_get_probability_q48() and
* @c transition_metrics_update_cache() to determine the most-likely next word
* for speculative prefetch.
*
* @param metrics The metrics structure to update.
* @param next_word_id Zero-based word ID of the word that followed the
* current word; must be < @p dict_size.
* @param dict_size Current dictionary size, used both as the bounds
* check for @p next_word_id and as the allocation size
* for the lazy-allocated @c transition_heat array.
* @return 0 on success; −1 on NULL @p metrics, out-of-bounds
* @p next_word_id, or allocation failure.
*/
int transition_metrics_record(WordTransitionMetrics *metrics, uint32_t next_word_id, uint32_t dict_size) {
if (!metrics || next_word_id >= dict_size) {
return -1;
}
/* Lazy allocation: only allocate transition_heat array when first transition occurs */
if (!metrics->transition_heat) {
metrics->transition_heat = (uint64_t *)calloc(dict_size, sizeof(uint64_t));
if (!metrics->transition_heat) {
return -1; /* Memory allocation failure */
}
}
/* Record the transition */
metrics->transition_heat[next_word_id]++;
metrics->total_transitions++;
return 0;
}
/**
* @brief Return the transition probability to @p target_word_id in Q48.16 format.
*
* Computes P(next = @p target_word_id | current word) as a Q48.16 fixed-point
* ratio:
* @code
* P = (transition_heat[target_word_id] << 16) / total_transitions
* @endcode
* using @c q48_div_u64() to guard against divide-by-zero.
*
* Returns 0 if:
* - @p metrics is NULL.
* - @c metrics->total_transitions == 0 (no transitions recorded yet).
* - @c metrics->transition_heat is NULL (lazy allocation has not occurred).
*
* The caller is responsible for ensuring @p target_word_id is within the
* bounds of the allocated @c transition_heat array; this function does not
* re-check bounds after verifying the NULL guard above (bounds were enforced
* during @c transition_metrics_record()).
*
* Consumed by @c transition_metrics_update_cache() (scans all words to find
* the maximum) and @c transition_metrics_should_speculate() (checks whether
* a specific word's probability exceeds @c SPECULATION_THRESHOLD_Q48).
*
* @param metrics The metrics structure to query.
* @param target_word_id Zero-based word ID whose transition probability is
* requested; must be within the dict_size used at record time.
* @return P(next = @p target_word_id) in Q48.16; 0 if unavailable.
*/
int64_t transition_metrics_get_probability_q48(const WordTransitionMetrics *metrics, uint32_t target_word_id) {
if (!metrics || metrics->total_transitions == 0) {
return 0;
}
/* Safety: Bounds check on target_word_id to prevent out-of-bounds read
* Note: transition_heat is allocated with dict_size passed to transition_metrics_record()
* Callers must ensure target_word_id < dict_size used during allocation */
if (!metrics->transition_heat) {
return 0;
}
uint64_t count = metrics->transition_heat[target_word_id];
/* Probability = count / total_transitions, in Q48.16 format */
/* = (count << 16) / total_transitions */
int64_t count_q48 = (int64_t)count << 16;
return q48_div_u64(count_q48, metrics->total_transitions);
}
/**
* @brief Scan the transition heat table and cache the highest-probability next word.
*
* Iterates over all @p dict_size entries in @c metrics->transition_heat[],
* calling @c transition_metrics_get_probability_q48() for each non-zero entry
* and tracking the maximum. After the scan:
* - @c metrics->max_transition_probability_q48 holds the peak probability (Q48.16).
* - @c metrics->most_likely_next_word_id holds the word ID of that peak.
*
* These two cached fields allow @c transition_metrics_should_speculate() to
* make a prefetch decision in O(1) without re-scanning the full table on every
* word dispatch.
*
* If @p metrics, @c transition_heat, or @c total_transitions are not valid,
* both fields are reset to 0 and the function returns immediately.
*
* Called after each @c transition_metrics_record() in the high-frequency
* interpreter path, so the implementation must be fast. The full @p dict_size
* scan runs in O(dict_size) and skips zero-count entries early.
*
* @param metrics The metrics structure to update.
* @param dict_size Number of entries in @c metrics->transition_heat[];
* must match the size used at allocation time.
*/
void transition_metrics_update_cache(WordTransitionMetrics *metrics, uint32_t dict_size) {
if (!metrics || !metrics->transition_heat || metrics->total_transitions == 0) {
metrics->max_transition_probability_q48 = 0;
metrics->most_likely_next_word_id = 0;
return;
}
int64_t max_prob_q48 = 0;
uint32_t max_idx = 0;
/* Find word with highest transition count */
for (uint32_t i = 0; i < dict_size; i++) {
if (metrics->transition_heat[i] > 0) {
int64_t prob_q48 = transition_metrics_get_probability_q48(metrics, i);
if (prob_q48 > max_prob_q48) {
max_prob_q48 = prob_q48;
max_idx = i;
}
}
}
metrics->max_transition_probability_q48 = max_prob_q48;
metrics->most_likely_next_word_id = max_idx;
}
/**
* @brief Record a successful speculative prefetch and the latency it saved.
*
* Increments @c metrics->prefetch_hits by one and accumulates @p latency_saved_ns
* (converted to Q48.16 via @c ns_to_q48()) into
* @c metrics->prefetch_latency_saved_q48. The accumulated total is reported by
* @c transition_metrics_stats_string() as the aggregate latency benefit of
* correct speculation.
*
* Called by the speculative-execution path when a prefetched word matches the
* word that was actually executed next.
*
* @param metrics The metrics structure to update; no-op if NULL.
* @param latency_saved_ns The number of nanoseconds saved by avoiding a
* full dictionary lookup on this particular hit.
*/
void transition_metrics_record_prefetch_hit(WordTransitionMetrics *metrics, int64_t latency_saved_ns) {
if (!metrics) return;
metrics->prefetch_hits++;
metrics->prefetch_latency_saved_q48 += ns_to_q48(latency_saved_ns);
}
/**
* @brief Record a failed speculative prefetch and its recovery overhead.
*
* Increments @c metrics->prefetch_misses by one and accumulates
* @p recovery_cost_ns (converted to Q48.16 via @c ns_to_q48()) into
* @c metrics->misprediction_cost_q48. The accumulated total is the aggregate
* penalty paid for incorrect speculation and is reported by
* @c transition_metrics_stats_string() as "Misprediction Cost".
*
* The net benefit of the pipelining subsystem is:
* @code
* net_ns = prefetch_latency_saved_q48 - misprediction_cost_q48
* @endcode
* A positive net indicates that speculation is profitable overall.
*
* Called by the speculative-execution path when the prefetched word does not
* match the word that was actually executed next (branch misprediction analogue).
*
* @param metrics The metrics structure to update; no-op if NULL.
* @param recovery_cost_ns The number of nanoseconds spent unwinding the
* incorrect speculation (cache flush, state restore).
*/
void transition_metrics_record_prefetch_miss(WordTransitionMetrics *metrics, int64_t recovery_cost_ns) {
if (!metrics) return;
metrics->prefetch_misses++;
metrics->misprediction_cost_q48 += ns_to_q48(recovery_cost_ns);
}
/**
* @brief Decide whether to speculatively prefetch @p target_word_id.
*
* Applies a two-gate policy before authorising speculation:
*
* 1. **Minimum sample gate:** @c metrics->total_transitions must be ≥
* @c MIN_SAMPLES_FOR_SPECULATION. Below this threshold the transition
* probabilities are statistically unreliable — speculation would be
* indistinguishable from guessing.
*
* 2. **Probability threshold gate:** the Q48.16 probability returned by
* @c transition_metrics_get_probability_q48(metrics, @p target_word_id)
* must be ≥ @c SPECULATION_THRESHOLD_Q48. Words with very low conditional
* probability of following the current word are not worth prefetching.
*
* Both gates must pass for the function to return 1. A Phase 4 ROI check
* (comparing expected latency savings against expected misprediction cost) is
* planned but not yet implemented; a TODO comment marks the extension point.
*
* Returns 0 if @p metrics or @c transition_heat are NULL, or if either gate
* fails.
*
* @param metrics The metrics structure to consult.
* @param target_word_id Zero-based ID of the candidate next word.
* @return 1 if speculation is recommended; 0 otherwise.
*/
int transition_metrics_should_speculate(const WordTransitionMetrics *metrics, uint32_t target_word_id) {
if (!metrics || !metrics->transition_heat) {
return 0; /* No data yet */
}
/* Check: do we have enough samples? */
if (metrics->total_transitions < MIN_SAMPLES_FOR_SPECULATION) {
return 0; /* Not enough data */
}
/* Get probability of this word following */
int64_t prob_q48 = transition_metrics_get_probability_q48(metrics, target_word_id);
/* Check: does probability exceed threshold? */
if (prob_q48 < SPECULATION_THRESHOLD_Q48) {
return 0; /* Probability too low */
}
/* TODO: Phase 4 - Add ROI check here */
/* For now, threshold check is sufficient */
return 1; /* Should speculate */
}
/**
* @brief Allocate and return a human-readable transition metrics summary string.
*
* Allocates a 2048-byte buffer and fills it with a multi-line report:
* - Total transitions recorded.
* - Prefetch attempts, hits (with hit-rate %), and misses.
* - Aggregate latency saved by correct speculation (from
* @c prefetch_latency_saved_q48, converted to integer ns via @c q48_to_ns()).
* - Aggregate misprediction cost (from @c misprediction_cost_q48).
* - Net benefit (saved − cost) in nanoseconds.
* - The most-likely next word ID and its raw Q48.16 probability.
*
* The caller is responsible for calling @c free() on the returned pointer.
* Returns NULL if @p metrics is NULL or @c malloc() fails.
*
* @param metrics The metrics structure to summarise.
* @return Heap-allocated NUL-terminated stats string; caller must @c free().
* NULL on allocation failure or NULL @p metrics.
*/
char *transition_metrics_stats_string(const WordTransitionMetrics *metrics) {
if (!metrics) return NULL;
/* Allocate buffer for stats string */
char *buf = (char *)malloc(2048);
if (!buf) return NULL;
int saved_ns = q48_to_ns(metrics->prefetch_latency_saved_q48);
int cost_ns = q48_to_ns(metrics->misprediction_cost_q48);
int net_ns = saved_ns - cost_ns;
/* Calculate hit rate */
uint64_t total_speculations = metrics->prefetch_attempts;
double hit_rate = (total_speculations > 0) ? (100.0 * metrics->prefetch_hits / total_speculations) : 0.0;
snprintf(buf, 2048,
"Transition Statistics:\n"
" Total Transitions: %lu\n"
" Prefetch Attempts: %lu\n"
" Prefetch Hits: %lu (%.1f%% hit rate)\n"
" Prefetch Misses: %lu\n"
" Latency Saved: %d ns\n"
" Misprediction Cost: %d ns\n"
" Net Benefit: %d ns\n"
" Most Likely Next: word[%u] (P=0x%lx Q48.16)\n",
metrics->total_transitions,
metrics->prefetch_attempts,
metrics->prefetch_hits, hit_rate,
metrics->prefetch_misses,
saved_ns,
cost_ns,
net_ns,
metrics->most_likely_next_word_id,
metrics->max_transition_probability_q48);
return buf;
}
/**
* @brief Reset a @c WordTransitionMetrics to empty without freeing the context window.
*
* Frees and NULLs @c metrics->transition_heat (so the next
* @c transition_metrics_record() will re-allocate it), then zeroes all
* counter and accumulator fields. Also zeroes the context-window array
* (if allocated) and resets @c context_window_pos to 0, and frees and NULLs
* @c context_transitions. @c actual_window_size and the @c context_window
* pointer itself are preserved — the window stays allocated and ready for
* reuse.
*
* Intended for DoE benchmark runs that need a clean statistical baseline
* between treatment cells without the overhead of full teardown and
* reinitialisation. Cheaper than @c transition_metrics_cleanup() +
* @c transition_metrics_init() because it avoids reallocating the context
* window.
*
* @param metrics The metrics structure to reset; no-op if NULL.
*/
void transition_metrics_reset(WordTransitionMetrics *metrics) {
if (!metrics) return;
if (metrics->transition_heat) {
free(metrics->transition_heat);
metrics->transition_heat = NULL;
}
metrics->total_transitions = 0;
metrics->prefetch_attempts = 0;
metrics->prefetch_hits = 0;
metrics->prefetch_misses = 0;
metrics->prefetch_latency_saved_q48 = 0;
metrics->misprediction_cost_q48 = 0;
metrics->max_transition_probability_q48 = 0;
metrics->most_likely_next_word_id = 0;
/* Phase 1 Extension: Reset context window */
if (metrics->context_window) {
memset(metrics->context_window, 0, metrics->actual_window_size * sizeof(uint32_t));
metrics->context_window_pos = 0;
}
if (metrics->context_transitions) {
free(metrics->context_transitions);
metrics->context_transitions = NULL;
}
metrics->total_context_transitions = 0;
}
/**
* @brief Release all heap memory held by a @c WordTransitionMetrics.
*
* Frees and NULLs:
* - @c metrics->transition_heat — the per-word transition count array.
* - @c metrics->context_window — the sliding context-window array.
* - @c metrics->context_transitions — the Phase 2 sparse hash table (if allocated).
*
* Does NOT zero the struct fields beyond NULLing the freed pointers. The
* caller must not use @p metrics after this call without a subsequent
* @c transition_metrics_init(). Contrast with @c transition_metrics_reset(),
* which keeps the context window allocated for reuse.
*
* No-op if @p metrics is NULL.
*
* @param metrics The metrics structure to clean up; no-op if NULL.
*/
void transition_metrics_cleanup(WordTransitionMetrics *metrics) {
if (!metrics) return;
if (metrics->transition_heat) {
free(metrics->transition_heat);
metrics->transition_heat = NULL;
}
/* Phase 1 Extension: Clean up context window */
if (metrics->context_window) {
free(metrics->context_window);
metrics->context_window = NULL;
}
if (metrics->context_transitions) {
free(metrics->context_transitions);
metrics->context_transitions = NULL;
}
}
/* ============================================================================
* Context-Aware Transition Functions (Phase 1 Extension)
* ============================================================================
*
* Phase 1: Collect data only (these functions are stubs)
* Phase 2: Implement analysis logic
* Phase 3: Use for adaptive decisions
*/
/**
* @brief Slide the context window forward by one word, appending @p word_id.
*
* Implements a fixed-length sliding window over the recent word-ID history.
* Each call shifts all existing entries one position to the left (dropping
* the oldest), then writes @p word_id into the last slot:
* @code
* context_window[0..n-2] = context_window[1..n-1]
* context_window[n-1] = word_id
* @endcode
* This produces a FIFO queue of the last @c actual_window_size word IDs
* that can be passed to @c transition_metrics_record_context() for
* context-sensitive transition tracking (Phase 2).
*
* Returns −1 and is a no-op if:
* - @p metrics is NULL.
* - @c context_window is NULL (allocation at init failed — degraded mode).
* - @c actual_window_size == 0.
*
* @param metrics The metrics structure whose context window is updated.
* @param word_id The word ID just executed; appended to the right of the window.
* @return 0 on success; −1 if the context window is unavailable.
*/
int transition_metrics_update_context_window(WordTransitionMetrics *metrics, uint32_t word_id) {
if (!metrics || !metrics->context_window || metrics->actual_window_size == 0) {
return -1; /* Context tracking not initialized */
}
/* Slide window forward: shift elements left, add new word on right */
for (uint32_t i = 0; i < metrics->actual_window_size - 1; i++) {
metrics->context_window[i] = metrics->context_window[i + 1];
}
/* Add new word at end of window */
metrics->context_window[metrics->actual_window_size - 1] = word_id;
return 0;
}
/**
* @brief Record a context-conditioned transition (Phase 1 collection stub).
*
* Accepts a @p context window of @p window_size preceding word IDs and the
* @p next_word_id that followed. In Phase 1 only the total count is tracked:
* @c metrics->total_context_transitions is incremented by one, providing a
* baseline count that Phase 2 analysis can use to size its hash tables.
*
* **Phase 2 TODO:** Build a sparse hash table keyed on the context pattern
* @c (context[0], …, context[window_size-1]) to record per-context next-word
* distributions. The Phase 2 analysis will feed
* @c transition_metrics_binary_chop_suggest_window() with accuracy data to
* tune the optimal window size.
*
* Returns −1 (no-op) if @p metrics or @p context are NULL, @p window_size is
* 0, or @p next_word_id ≥ @p dict_size.
*
* @param metrics The metrics structure to update.
* @param context Array of @p window_size word IDs preceding @p next_word_id.
* @param window_size Number of entries in @p context; must be > 0.
* @param next_word_id Word ID that followed the context sequence.
* @param dict_size Current dictionary size; used for bounds checking
* @p next_word_id.
* @return 0 on success; −1 on invalid arguments.
*/
int transition_metrics_record_context(WordTransitionMetrics *metrics,
const uint32_t *context,
uint32_t window_size,
uint32_t next_word_id,
uint32_t dict_size) {
if (!metrics || !context || window_size == 0 || next_word_id >= dict_size) {
return -1;
}
/* Phase 1: Just count total context transitions for validation */
metrics->total_context_transitions++;
/* TODO Phase 2: Build sparse hash table of context patterns
* For now, we collect data but don't analyze it.
* This is the foundation for Phase 2's binary chop tuning.
*/
return 0;
}
/**
* @brief Allocate and return a context-window status report string (Phase 1 stub).
*
* Allocates a 1024-byte buffer and fills it with a brief Phase 1 collection
* status message:
* - @c actual_window_size — the active window width (0 if allocation failed).
* - @c total_context_transitions — the number of context transitions recorded.
* - A "[Phase 1 Collection - Phase 2 Analysis Pending]" status line.
*
* Phase 2 will replace this stub with a real accuracy report showing per-window-size
* prediction accuracy derived from the sparse context-pattern hash table. The
* accuracy data will feed @c transition_metrics_binary_chop_suggest_window()
* to converge on the optimal context window width.
*
* The caller is responsible for calling @c free() on the returned pointer.
* Returns NULL if @p metrics is NULL or @c malloc() fails.
*
* @param metrics The metrics structure to report on.
* @return Heap-allocated NUL-terminated string; caller must @c free().
* NULL on allocation failure or NULL @p metrics.
*/
char *transition_metrics_context_accuracy_string(const WordTransitionMetrics *metrics) {
if (!metrics) return NULL;
char *buf = (char *)malloc(1024);
if (!buf) return NULL;
/* Phase 1: Stub - just report collection status */
snprintf(buf, 1024,
"Context Metrics Status:\n"
" Actual Window Size: %u\n"
" Total Context Transitions: %lu\n"
" Status: [Phase 1 Collection - Phase 2 Analysis Pending]\n",
metrics->actual_window_size,
metrics->total_context_transitions);
return buf;
}
/**
* @brief Suggest a new context window size using binary-chop search (Phase 1 stub).
*
* In Phase 2 this function will implement a binary-chop search over window sizes
* to converge on the width that maximises context-prediction accuracy:
* - Start at window = 2.
* - If accuracy improves when doubling, try 4; if it declines, try 1.
* - Continue halving/doubling until the accuracy delta falls below a threshold.
*
* **Phase 1 stub behaviour:** Doubles the current window each call up to 8,
* then wraps back to 1:
* - @p current_window == 1 → suggests 2
* - @p current_window == 2 → suggests 4
* - @p current_window == 4 → suggests 8
* - @p current_window ≥ 8 → suggests 1 (cycle back)
* - Any other value → returns @p current_window unchanged.
*
* The @p accuracy_at_current parameter (prediction accuracy [0.0, 1.0] at the
* current window size) is accepted for API stability with the Phase 2 caller
* but is not used in the stub.
*
* @param metrics The metrics structure (unused in Phase 1 stub;
* reserved for Phase 2 accuracy history).
* @param current_window Currently active context window size.
* @param accuracy_at_current Prediction accuracy at @p current_window
* (unused in Phase 1 stub; range [0.0, 1.0]).
* @return Suggested new window size.
*/
uint32_t transition_metrics_binary_chop_suggest_window(const WordTransitionMetrics *metrics,
uint32_t current_window,
double accuracy_at_current) {
(void)metrics;
(void)accuracy_at_current;
/* Phase 1: Stub - just return doubled window size per user's request
* Phase 2 will implement actual binary chop search:
* - Start at window=2
* - If accuracy improves, try doubling (2→4)
* - If accuracy declines, try halving (4→2)
* - Converge to optimal size
*/
if (current_window >= 8) return 1; /* Maximum: back to 1 */
if (current_window == 1) return 2; /* 1 → 2 */
if (current_window == 2) return 4; /* 2 → 4 (doubling) */
if (current_window == 4) return 8; /* 4 → 8 (doubling) */
return current_window; /* Fallback */
}
v3/src/physics_runtime.c
+720
View File
@@ -0,0 +1,720 @@
/*
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.
*/
/*
*** StarForth ***
physics_runtime.c - Phase 1 physics runtime scaffolding
Implements the host snapshot shim (POSIX) and provides a
fixed-size analytics heap compatible with the HOLA shared-memory layout.
The implementation favours predictable costs and clear extension points for
future governance-approved features.
*/
#include "physics_runtime.h"
#include "platform_time.h"
/* STARFORTH_MINIMAL: kernel build — skip Linux /proc runtime monitoring.
* Provide stub API so vmcore link succeeds; none of these are called. */
#if defined(STARFORTH_MINIMAL)
int physics_runtime_init(size_t analytics_heap_bytes)
{ (void)analytics_heap_bytes; return 0; }
void physics_runtime_shutdown(void) {}
int physics_analytics_publish_event(uint32_t channel, const void *payload, uint16_t payload_bytes)
{ (void)channel; (void)payload; (void)payload_bytes; return 0; }
int physics_host_snapshot(physics_host_snapshot_t *out)
{ (void)out; return -1; }
#else /* !STARFORTH_MINIMAL — full Linux/POSIX implementation below */
#include <errno.h>
#include <inttypes.h>
#include <limits.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#ifndef PATH_MAX
#define PATH_MAX 4096
#endif
/* HISTORICAL: L4Re support has been removed as an active target.
* #ifdef __l4__
* #include <l4/sys/kip.h>
* #include <l4/re/env.h>
* #endif
*/
#include <sched.h>
#include <sys/time.h>
#include <sys/types.h>
#include <time.h>
#include <unistd.h>
#include <ctype.h>
/* ------------------------------------------------------------------------- */
/* Analytics heap internals */
/* ------------------------------------------------------------------------- */
typedef struct physics_runtime_state {
physics_analytics_heap_t heap;
int heap_ready;
uint64_t backend_seq;
} physics_runtime_state_t;
static physics_runtime_state_t g_runtime = {0};
/**
* @brief Round @c value up to the next multiple of @c alignment.
*
* @c alignment must be a power of two. Used internally to satisfy
* cache-line and struct alignment requirements in the analytics heap.
*
* @param value Value to align
* @param alignment Alignment boundary (must be power of two)
* @return Smallest multiple of @c alignment that is >= @c value
*/
static size_t align_up(size_t value, size_t alignment) {
return (value + alignment - 1u) & ~(alignment - 1u);
}
/* HISTORICAL: this whole section (through the matching "!__l4__" comment
* below) was wrapped in `#if !defined(__l4__)` -- these PSI/cgroup helpers
* are Linux-specific and were excluded from L4Re builds. L4Re support has
* been removed as an active target, so the guard (now always-true) has
* been removed too. */
/**
* @brief Parse a floating-point average field from a Linux PSI file line.
*
* Searches @c line for @c tag (e.g. @c "avg10="), reads the following
* floating-point value, and returns it scaled to millipercentage (×1000).
* Returns 0 on parse failure or negative value.
*
* @param line Raw text line from a @c /proc/pressure/ PSI file (cpu, memory, or io)
* @param tag Field prefix to locate (e.g. @c "avg10=")
* @return Scaled value in milli-units, or 0 on failure
*/
static uint32_t parse_avg_milli(const char *line, const char *tag) {
const char *p = strstr(line, tag);
if (!p) return 0;
p += strlen(tag);
errno = 0;
char *end = NULL;
double value = strtod(p, &end);
if (errno != 0 || end == p || value < 0.0) {
return 0;
}
double scaled = value * 1000.0;
if (scaled > (double) UINT32_MAX) scaled = (double) UINT32_MAX;
return (uint32_t)(scaled + 0.5);
}
/**
* @brief Read a Linux Pressure Stall Information (PSI) file.
*
* Parses @c /proc/pressure/{cpu,io,memory} and populates the six output
* pointers with avg10/avg60/avg300 milli-values for both the @c some and
* @c full stall categories. Any output pointer may be NULL to skip that field.
* Returns a bitmask: bit 0 set if @c some line was found, bit 1 if @c full.
*
* @param path Path to PSI file (e.g. @c "/proc/pressure/cpu")
* @param some10 avg10 for the @c some stall category (milli-units), or NULL
* @param some60 avg60 for the @c some stall category, or NULL
* @param some300 avg300 for the @c some stall category, or NULL
* @param full10 avg10 for the @c full stall category, or NULL
* @param full60 avg60 for the @c full stall category, or NULL
* @param full300 avg300 for the @c full stall category, or NULL
* @return Bitmask of parsed sections (0 = none, 1 = some, 2 = full, 3 = both)
*/
static int read_psi_file(const char *path,
uint32_t *some10, uint32_t *some60, uint32_t *some300,
uint32_t *full10, uint32_t *full60, uint32_t *full300) {
FILE *f = fopen(path, "r");
if (!f) {
return 0;
}
char line[256];
int mask = 0;
while (fgets(line, sizeof(line), f)) {
if (strncmp(line, "some", 4) == 0) {
if (some10) *some10 = parse_avg_milli(line, "avg10=");
if (some60) *some60 = parse_avg_milli(line, "avg60=");
if (some300) *some300 = parse_avg_milli(line, "avg300=");
mask |= 1;
} else if (strncmp(line, "full", 4) == 0) {
if (full10) *full10 = parse_avg_milli(line, "avg10=");
if (full60) *full60 = parse_avg_milli(line, "avg60=");
if (full300) *full300 = parse_avg_milli(line, "avg300=");
mask |= 2;
}
}
fclose(f);
return mask;
}
/**
* @brief Read aggregate CPU jiffy totals from @c /proc/stat.
*
* Parses the first @c cpu line from @c /proc/stat and sums user, nice, system,
* idle, iowait, irq, softirq, and steal columns into @c *total. The idle
* estimate is @c idle_j + @c iowait. Either output pointer may be NULL.
*
* @param total Output: total jiffy count across all categories
* @param idle Output: idle + iowait jiffies (effective idle)
* @return 0 on success, -1 on file open or parse failure
*/
static int read_proc_stat_totals(uint64_t *total, uint64_t *idle) {
FILE *f = fopen("/proc/stat", "r");
if (!f) {
return -1;
}
char line[256];
if (!fgets(line, sizeof(line), f)) {
fclose(f);
return -1;
}
fclose(f);
unsigned long long user = 0, nice = 0, system = 0, idle_j = 0;
unsigned long long iowait = 0, irq = 0, softirq = 0, steal = 0;
int scanned = sscanf(line, "cpu %llu %llu %llu %llu %llu %llu %llu %llu",
&user, &nice, &system, &idle_j, &iowait, &irq, &softirq, &steal);
if (scanned < 4) {
return -1;
}
unsigned long long total_j = user + nice + system + idle_j + iowait + irq + softirq + steal;
if (total) *total = total_j;
if (idle) *idle = idle_j + iowait;
return 0;
}
/**
* @brief Resolve the cgroup v2 filesystem path for the current process.
*
* Reads @c /proc/self/cgroup, finds the cgroup2 hierarchy entry (the line
* with @c "::" separator), and constructs the full sysfs path under
* @c /sys/fs/cgroup. The root cgroup ("/") maps to @c /sys/fs/cgroup itself.
*
* @param out Output buffer for the resolved path
* @param out_sz Size of @c out in bytes
* @return 0 on success, -1 if the path could not be resolved
*/
static int resolve_cgroup_path(char *out, size_t out_sz) {
FILE *f = fopen("/proc/self/cgroup", "r");
if (!f) {
return -1;
}
char line[512];
int rc = -1;
while (fgets(line, sizeof(line), f)) {
char *sep = strstr(line, "::");
if (!sep) continue;
char *path = sep + 2;
char *newline = strchr(path, '\n');
if (newline) *newline = '\0';
if (*path == '\0' || strcmp(path, "/") == 0) {
if (snprintf(out, out_sz, "%s", "/sys/fs/cgroup") < (int) out_sz) {
rc = 0;
break;
}
} else {
if (snprintf(out, out_sz, "/sys/fs/cgroup%s", path) < (int) out_sz) {
rc = 0;
break;
}
}
}
fclose(f);
return rc;
}
/**
* @brief Read the cumulative CPU usage in microseconds from a cgroup's @c cpu.stat.
*
* Opens @c <cgpath>/cpu.stat and extracts the @c usage_usec field.
* Returns 0 if the file cannot be opened or the field is absent.
*
* @param cgpath Absolute path to the cgroup directory
* @return Cumulative CPU usage in microseconds, or 0 on failure
*/
static uint64_t read_cgroup_cpu_usage_us(const char *cgpath) {
char path[PATH_MAX];
if (snprintf(path, sizeof(path), "%s/cpu.stat", cgpath) >= (int) sizeof(path)) {
return 0;
}
FILE *f = fopen(path, "r");
if (!f) {
return 0;
}
char line[256];
uint64_t value = 0;
while (fgets(line, sizeof(line), f)) {
if (sscanf(line, "usage_usec %" SCNu64, &value) == 1) {
break;
}
}
fclose(f);
return value;
}
/**
* @brief Read current memory usage in bytes from a cgroup's @c memory.current.
*
* Opens @c <cgpath>/memory.current and reads the single integer value.
* Returns 0 if the file cannot be opened or parsed.
*
* @param cgpath Absolute path to the cgroup directory
* @return Current memory usage in bytes, or 0 on failure
*/
static uint64_t read_cgroup_memory_current(const char *cgpath) {
char path[PATH_MAX];
if (snprintf(path, sizeof(path), "%s/memory.current", cgpath) >= (int) sizeof(path)) {
return 0;
}
FILE *f = fopen(path, "r");
if (!f) {
return 0;
}
unsigned long long value = 0;
if (fscanf(f, "%llu", &value) != 1) {
value = 0;
}
fclose(f);
return value;
}
/* end of the section historically wrapped in `#if !defined(__l4__)` */
/**
* @brief Allocate and initialise the HOLA analytics heap.
*
* Allocates a contiguous block of at least @c requested_bytes (or
* @c PHYSICS_ANALYTICS_DEFAULT_HEAP_BYTES if 0), enforcing a minimum that
* accommodates the header plus 512 KB ring buffer. Partitions the block into
* header (cache-line aligned), ring (60%), summary (30%), and scratch regions,
* then populates the @c physics_analytics_header_t with magic, version, and
* offsets. Safe to call repeatedly — returns 0 immediately if already ready.
*
* @param requested_bytes Desired heap size in bytes (0 = use default)
* @return 0 on success, -1 if allocation failed
*/
static int analytics_heap_allocate(size_t requested_bytes) {
if (g_runtime.heap_ready) {
return 0;
}
size_t bytes = requested_bytes;
if (bytes == 0) {
bytes = PHYSICS_ANALYTICS_DEFAULT_HEAP_BYTES;
}
/* Enforce minimum viable size: header + ring + summary */
const size_t min_bytes = align_up(sizeof(physics_analytics_header_t), 64) + (512u * 1024u);
if (bytes < min_bytes) {
bytes = min_bytes;
}
uint8_t *base = NULL;
/* HISTORICAL: this used to be an #if !defined(__l4__)/#else branch --
* both did an identical malloc(), with the L4Re side noting "simple
* malloc is fine for now; future work can switch to dataspace". L4Re
* support has been removed as an active target. */
base = (uint8_t *) malloc(bytes);
if (!base) {
return -1;
}
memset(base, 0, bytes);
physics_analytics_heap_t heap = {0};
heap.base = base;
heap.bytes = bytes;
size_t header_bytes = align_up(sizeof(physics_analytics_header_t), 64);
heap.header = (physics_analytics_header_t *) base;
/* Split remaining space into ring (60%), summary (30%), scratch (remainder) */
size_t remaining = bytes - header_bytes;
size_t ring_bytes = align_up((remaining * 6u) / 10u, 64);
if (ring_bytes > remaining) ring_bytes = remaining;
size_t summary_bytes = remaining > ring_bytes ? align_up((remaining - ring_bytes) * 3u / 4u, 64) : 0;
if (summary_bytes > remaining - ring_bytes) summary_bytes = remaining - ring_bytes;
size_t scratch_bytes = remaining - ring_bytes - summary_bytes;
heap.ring = base + header_bytes;
heap.ring_bytes = ring_bytes;
heap.summary = heap.ring + ring_bytes;
heap.summary_bytes = summary_bytes;
heap.scratch = heap.summary + summary_bytes;
heap.scratch_bytes = scratch_bytes;
/* Populate header */
physics_analytics_header_t *hdr = heap.header;
hdr->magic = HOLA_SHARED_MAGIC;
hdr->version_major = HOLA_PROTOCOL_MAJOR;
hdr->version_minor = HOLA_PROTOCOL_MINOR;
hdr->heap_bytes = (uint32_t) bytes;
hdr->ring_offset = (uint32_t) header_bytes;
hdr->ring_bytes = (uint32_t) ring_bytes;
hdr->summary_offset = (uint32_t)(heap.summary - heap.base);
hdr->summary_bytes = (uint32_t) summary_bytes;
hdr->scratch_offset = (uint32_t)(heap.scratch - heap.base);
hdr->scratch_bytes = (uint32_t) scratch_bytes;
hdr->produce_seq = 0;
hdr->consume_seq = 0;
hdr->write_offset = 0;
hdr->read_offset = 0;
hdr->dropped_events = 0;
hdr->flags = 0;
g_runtime.heap = heap;
g_runtime.heap_ready = 1;
g_runtime.backend_seq = 0;
return 0;
}
/**
* @brief Free the analytics heap and reset all global heap state.
*
* Safe to call when the heap is not ready. After this call,
* @c g_runtime.heap_ready is 0 and the heap pointer is NULL.
*/
static void analytics_heap_release(void) {
if (!g_runtime.heap_ready) {
return;
}
free(g_runtime.heap.base);
g_runtime.heap = (physics_analytics_heap_t) {
0
};
g_runtime.heap_ready = 0;
g_runtime.backend_seq = 0;
}
/**
* @brief Compute free bytes available in the analytics ring buffer.
*
* Assumes single-producer, single-consumer access with no concurrent writers.
* Clamps out-of-range @c write_offset and @c read_offset before computing.
*
* @param hdr Pointer to the analytics heap header
* @return Number of free bytes available for a new event write
*/
static size_t analytics_ring_free(const physics_analytics_header_t *hdr) {
uint32_t write = hdr->write_offset;
uint32_t read = hdr->read_offset;
uint32_t size = hdr->ring_bytes;
if (write >= size) write = 0;
if (read >= size) read = 0;
if (write >= read) {
return (size_t) (size - write + read - 1u);
}
return (size_t) (read - write - 1u);
}
/* ------------------------------------------------------------------------- */
/* Public API */
/* ------------------------------------------------------------------------- */
/**
* @brief Initialise the physics runtime and analytics heap.
*
* Must be called before any other physics_runtime_* function.
* Idempotent — safe to call multiple times; subsequent calls return 0
* immediately without re-allocating.
*
* @param analytics_heap_bytes Desired analytics heap size (0 = default)
* @return 0 on success, -1 on allocation failure
*/
int physics_runtime_init(size_t analytics_heap_bytes) {
return analytics_heap_allocate(analytics_heap_bytes);
}
/**
* @brief Shut down the physics runtime and release the analytics heap.
*
* Safe to call when the runtime was never initialised. After this call
* the analytics heap is gone and no events can be published until
* @c physics_runtime_init() is called again.
*/
void physics_runtime_shutdown(void) {
analytics_heap_release();
}
/**
* @brief Return a pointer to the live analytics heap descriptor.
*
* @return Pointer to the heap descriptor, or NULL if not yet initialised
*/
const physics_analytics_heap_t *physics_analytics_heap_info(void) {
return g_runtime.heap_ready ? &g_runtime.heap : NULL;
}
/**
* @brief Publish an analytics event into the ring buffer.
*
* Writes a @c physics_analytics_event_header_t followed by the payload
* (8-byte padded) into the ring at the current write offset. If insufficient
* space is available, increments @c dropped_events and returns -1. The event
* is timestamped with @c sf_monotonic_ns() at write time.
*
* @param channel Event channel identifier (e.g. @c PHYSICS_ANALYTICS_CHANNEL_HOST_SNAPSHOT)
* @param payload Event payload bytes (must not be NULL)
* @param payload_bytes Length of payload in bytes
* @return 0 on success, -1 if the heap is not ready, payload is NULL, or ring is full
*/
int physics_analytics_publish_event(uint32_t channel, const void *payload, uint16_t payload_bytes) {
if (!g_runtime.heap_ready || !payload) {
return -1;
}
physics_analytics_header_t *hdr = g_runtime.heap.header;
uint8_t *ring = g_runtime.heap.ring;
uint32_t ring_bytes = hdr->ring_bytes;
if (ring_bytes == 0) {
return -1;
}
size_t padded_payload = align_up(payload_bytes, 8);
size_t total_bytes = sizeof(physics_analytics_event_header_t) + padded_payload;
if (total_bytes >= ring_bytes) {
/* Payload cannot fit even into an empty ring */
hdr->dropped_events++;
return -1;
}
size_t free_bytes = analytics_ring_free(hdr);
if (total_bytes > free_bytes) {
hdr->dropped_events++;
return -1;
}
uint32_t write = hdr->write_offset;
if (write >= ring_bytes) {
write = 0;
}
if (write + total_bytes > ring_bytes) {
size_t tail = ring_bytes - write;
memset(ring + write, 0, tail);
write = 0;
}
physics_analytics_event_header_t *evt = (physics_analytics_event_header_t *) (ring + write);
evt->channel = channel;
evt->payload_bytes = payload_bytes;
evt->reserved = 0;
evt->timestamp_ns = sf_monotonic_ns();
memcpy((uint8_t *) (evt + 1), payload, payload_bytes);
if (padded_payload > payload_bytes) {
memset(((uint8_t *) (evt + 1)) + payload_bytes, 0, padded_payload - payload_bytes);
}
write += (uint32_t) total_bytes;
if (write >= ring_bytes) {
write = 0;
}
hdr->write_offset = write;
hdr->produce_seq++;
return 0;
}
/* ------------------------------------------------------------------------- */
/* Host snapshot shim */
/* ------------------------------------------------------------------------- */
/**
* @brief Collect a host system snapshot using POSIX / Linux interfaces.
*
* Populates @c out with monotonic and realtime timestamps, CPU count,
* scheduler policy and priority, load average (scaled × 1000), runnable
* thread estimate, PSI pressure readings, @c /proc/stat CPU jiffy totals,
* and cgroup v2 CPU usage and memory current values. Sets flags in
* @c out->flags to indicate which fields were successfully populated.
*
* @param out Output snapshot struct; zeroed and populated by this function
* @return 0 on success
*/
static int snapshot_posix(physics_host_snapshot_t *out) {
memset(out, 0, sizeof(*out));
out->backend = PHYSICS_HOST_BACKEND_POSIX;
out->monotonic_time_ns = sf_monotonic_ns();
out->realtime_ns = sf_realtime_ns();
long cpu_count = sysconf(_SC_NPROCESSORS_ONLN);
out->cpu_count = (cpu_count > 0) ? (uint32_t) cpu_count : 1u;
/* Scheduler information */
int policy = sched_getscheduler(0);
if (policy >= 0) {
out->scheduler_policy = (uint32_t) policy;
struct sched_param param = {0};
if (sched_getparam(0, &param) == 0) {
out->scheduler_priority = (uint32_t) param.sched_priority;
}
#if defined(_POSIX_PRIORITY_SCHEDULING)
if (policy == SCHED_RR) {
struct timespec ts = {0};
if (sched_rr_get_interval(0, &ts) == 0) {
out->scheduler_quantum_ns = (uint32_t)((ts.tv_sec * 1000000000LL) + ts.tv_nsec);
}
}
#endif
}
/* Load estimate (scaled by 1000) */
#if defined(_GNU_SOURCE)
double loads[3] = {0.0, 0.0, 0.0};
if (getloadavg(loads, 3) > 0) {
out->load_avg_milli = (uint32_t)(loads[0] * 1000.0);
}
#endif
/* Runnable thread estimate: best effort via load average */
if (out->load_avg_milli > 0) {
out->runnable_threads = (out->load_avg_milli + 999u) / 1000u;
}
int psi_mask = 0;
psi_mask |= read_psi_file("/proc/pressure/cpu",
&out->psi_cpu_some_avg10_milli,
&out->psi_cpu_some_avg60_milli,
&out->psi_cpu_some_avg300_milli,
&out->psi_cpu_full_avg10_milli,
&out->psi_cpu_full_avg60_milli,
&out->psi_cpu_full_avg300_milli);
psi_mask |= read_psi_file("/proc/pressure/io",
&out->psi_io_some_avg10_milli,
&out->psi_io_some_avg60_milli,
&out->psi_io_some_avg300_milli,
&out->psi_io_full_avg10_milli,
&out->psi_io_full_avg60_milli,
&out->psi_io_full_avg300_milli);
psi_mask |= read_psi_file("/proc/pressure/memory",
&out->psi_mem_some_avg10_milli,
&out->psi_mem_some_avg60_milli,
&out->psi_mem_some_avg300_milli,
NULL, NULL, NULL);
if (psi_mask) {
out->flags |= PHYSICS_HOST_FLAG_PSI;
}
uint64_t total_jiffies = 0;
uint64_t idle_jiffies = 0;
if (read_proc_stat_totals(&total_jiffies, &idle_jiffies) == 0) {
out->cpu_total_jiffies = total_jiffies;
out->cpu_idle_jiffies = idle_jiffies;
out->flags |= PHYSICS_HOST_FLAG_CPU_STAT;
}
char cgpath[PATH_MAX];
if (resolve_cgroup_path(cgpath, sizeof(cgpath)) == 0) {
uint64_t usage = read_cgroup_cpu_usage_us(cgpath);
uint64_t mem_cur = read_cgroup_memory_current(cgpath);
out->cgroup_cpu_usage_us = usage;
out->cgroup_memory_current_bytes = mem_cur;
if (usage != 0 || mem_cur != 0) {
out->flags |= PHYSICS_HOST_FLAG_CGROUP;
}
}
out->backend_seq = ++g_runtime.backend_seq;
return 0;
}
/* HISTORICAL: an L4Re backend used to sit here, selected ahead of
* snapshot_posix() by physics_host_snapshot() below whenever __l4__ was
* defined. L4Re support has been removed as an active target.
*
* static int snapshot_l4re(physics_host_snapshot_t *out) {
* memset(out, 0, sizeof(*out));
* out->backend = PHYSICS_HOST_BACKEND_L4RE;
* out->monotonic_time_ns = sf_monotonic_ns();
* out->realtime_ns = sf_realtime_ns();
*
* l4_kernel_info_t *kip = l4re_kip();
* (void) kip;
* out->cpu_count = 1u; // TODO: query processor count from KIP once available
*
* out->backend_seq = ++g_runtime.backend_seq;
* return 0;
* }
*/
/**
* @brief Capture a host environment snapshot and publish it to the analytics ring.
*
* Uses the POSIX backend. On success also publishes the snapshot as a
* @c PHYSICS_ANALYTICS_CHANNEL_HOST_SNAPSHOT event to the analytics ring
* buffer (if the heap is initialised).
*
* @param out Output snapshot struct to populate (must not be NULL)
* @return 0 on success, -1 if @c out is NULL or the backend fails
*/
int physics_host_snapshot(physics_host_snapshot_t *out) {
if (!out) {
return -1;
}
int rc;
/* HISTORICAL: an #ifdef __l4__ block here tried snapshot_l4re() first
* and `goto publish` past snapshot_posix() on success. L4Re support
* has been removed as an active target. */
rc = snapshot_posix(out);
if (rc != 0) {
return rc;
}
if (g_runtime.heap_ready) {
physics_analytics_publish_event(PHYSICS_ANALYTICS_CHANNEL_HOST_SNAPSHOT,
out,
(uint16_t) sizeof(*out));
}
return 0;
}
#endif /* STARFORTH_MINIMAL */
/* ------------------------------------------------------------------------- */
/* End */
/* ------------------------------------------------------------------------- */
v3/src/platform/README.md
+20
View File
@@ -0,0 +1,20 @@
# src/platform/
Platform abstraction layer for the hosted VM build.
- `alloc_host.c` — hosted (`malloc`-backed) allocator implementation of
`include/platform_alloc.h`.
- `alloc_kernel.c` — a kernel-side allocator implementation of the same
interface. Note: `src/starkernel/vm/alloc_kernel.c` is the copy actually
referenced by `Makefile.starkernel`'s kernel build; this one under
`src/platform/` is not wired into any build target — check before relying
on it.
- `platform_init.c` — platform-specific initialization dispatch.
- `threading.c` — threading primitives backing the heartbeat background
thread (`HEARTBEAT_THREAD_ENABLED=1`).
Subdirectories:
- `linux/time.c` — POSIX (`clock_gettime`) timing backend.
- `l4re/time.c` — HISTORICAL: L4Re/Fiasco.OC timing backend. L4Re was a
supported platform target through mid-2026; it has been removed as an
active target and this file is no longer wired into any build.
v3/src/platform/alloc_host.c
+164
View File
@@ -0,0 +1,164 @@
/*
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.
*/
/*
* platform/alloc_host.c - Host (Linux/POSIX) memory allocator
*
* Simple wrapper around standard malloc/free with statistics tracking.
*/
#include "../../include/platform_alloc.h"
#include <stdlib.h>
#include <string.h>
/* Statistics tracking */
static sf_alloc_stats_t g_stats = {0};
/**
* @brief Initialise the host allocator statistics.
*
* Resets the @c g_stats struct to zero. Safe to call multiple times;
* subsequent calls simply reset the counters. No heap memory is allocated
* by this function — the underlying allocator is the system @c malloc.
*
* @return 0 always (cannot fail on the hosted path)
*/
int sf_alloc_init(void)
{
memset(&g_stats, 0, sizeof(g_stats));
return 0;
}
/**
* @brief Allocate @c size bytes from the system heap.
*
* Delegates to @c malloc(). On success, increments @c g_stats.used_bytes
* and @c g_stats.alloc_count, and updates @c g_stats.peak_bytes if the
* new used total exceeds the recorded peak.
*
* @param size Number of bytes to allocate; 0 returns NULL
* @return Pointer to allocated memory, or NULL on allocation failure or zero size
*/
void* sf_malloc(size_t size)
{
if (size == 0) return NULL;
void* ptr = malloc(size);
if (ptr)
{
g_stats.used_bytes += size;
g_stats.alloc_count++;
if (g_stats.used_bytes > g_stats.peak_bytes)
{
g_stats.peak_bytes = g_stats.used_bytes;
}
}
return ptr;
}
/**
* @brief Allocate a zero-initialised array of @c count elements of @c size bytes each.
*
* Delegates to @c calloc(). Updates statistics the same way as @c sf_malloc():
* adds @c count*size to @c used_bytes, increments @c alloc_count, and updates
* @c peak_bytes.
*
* @param count Number of elements; 0 returns NULL
* @param size Size of each element in bytes; 0 returns NULL
* @return Pointer to zero-filled memory, or NULL on allocation failure or zero arguments
*/
void* sf_calloc(size_t count, size_t size)
{
if (count == 0 || size == 0) return NULL;
void* ptr = calloc(count, size);
if (ptr)
{
size_t total = count * size;
g_stats.used_bytes += total;
g_stats.alloc_count++;
if (g_stats.used_bytes > g_stats.peak_bytes)
{
g_stats.peak_bytes = g_stats.used_bytes;
}
}
return ptr;
}
/**
* @brief Resize a previously allocated block to @c new_size bytes.
*
* Delegates to @c realloc(). On success, increments @c g_stats.alloc_count.
* The exact byte delta is not tracked because the original allocation size is
* not stored alongside the pointer — @c used_bytes is therefore approximate
* after any @c sf_realloc() call. For accurate accounting, wrap allocations
* with size-tracking headers.
*
* @param ptr Pointer to an existing allocation, or NULL (behaves like @c sf_malloc)
* @param new_size Desired new size in bytes; 0 may free the block (platform-defined)
* @return Pointer to resized memory, or NULL on failure (original block unchanged)
*/
void* sf_realloc(void* ptr, size_t new_size)
{
void* new_ptr = realloc(ptr, new_size);
if (new_ptr)
{
/* Note: Can't track exact delta without size tracking */
g_stats.alloc_count++;
}
return new_ptr;
}
/**
* @brief Release a previously allocated block back to the system heap.
*
* Delegates to @c free(). Increments @c g_stats.free_count on non-NULL @c ptr.
* The freed byte count is not subtracted from @c used_bytes because the
* original size is not tracked — see @c sf_realloc() note.
*
* @param ptr Pointer to free; NULL is a safe no-op
*/
void sf_free(void* ptr)
{
if (!ptr) return;
/* Note: We can't track exact bytes freed without size tracking.
* For accurate stats, would need to wrap allocations with headers.
* For now, just count frees. */
g_stats.free_count++;
free(ptr);
}
/**
* @brief Copy the current allocator statistics into @c stats.
*
* Fills @c *stats with a snapshot of @c g_stats. Note that @c used_bytes
* overstates the live total when blocks have been freed or reallocated,
* because freed sizes are not tracked. @c free_count is accurate.
*
* @param stats Output buffer to populate; no-op if NULL
*/
void sf_alloc_get_stats(sf_alloc_stats_t* stats)
{
if (!stats) return;
*stats = g_stats;
}
v3/src/platform/alloc_kernel.c
+225
View File
@@ -0,0 +1,225 @@
/*
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.
*/
/*
* platform/alloc_kernel.c - Kernel (bare-metal) memory allocator
*
* Static arena with bump allocation. Free is a no-op.
* This is appropriate for kernel use where:
* - VM is long-lived (no restart)
* - Allocations happen at init time
* - Runtime allocations are rare
*
* Arena size: 4MB by default (configurable via SF_ARENA_SIZE)
*/
#include "../../include/platform_alloc.h"
#include <stdint.h>
#ifndef SF_ARENA_SIZE
#define SF_ARENA_SIZE (4 * 1024 * 1024) /* 4MB default */
#endif
/* Alignment for all allocations (8 bytes for 64-bit safety) */
#define SF_ALIGN 8
#define SF_ALIGN_UP(x) (((x) + (SF_ALIGN - 1)) & ~(SF_ALIGN - 1))
/* Static arena */
static uint8_t g_arena[SF_ARENA_SIZE] __attribute__((aligned(SF_ALIGN)));
static size_t g_arena_offset = 0;
static int g_initialized = 0;
/* Statistics */
static sf_alloc_stats_t g_stats = {0};
/**
* @brief Initialise the kernel bump allocator.
*
* Resets @c g_arena_offset to zero and clears all @c g_stats fields.
* Sets @c g_initialized so that @c sf_malloc() skips the lazy-init guard.
* Safe to call at any point; all prior allocations become invalid after a
* reset, so this must only be called before any VM allocation takes place.
*
* @return 0 always (cannot fail)
*/
int sf_alloc_init(void)
{
g_arena_offset = 0;
g_initialized = 1;
g_stats.total_bytes = SF_ARENA_SIZE;
g_stats.used_bytes = 0;
g_stats.peak_bytes = 0;
g_stats.alloc_count = 0;
g_stats.free_count = 0;
return 0;
}
/*
* @brief Allocate @c size bytes from the static kernel arena.
*
* Advances @c g_arena_offset by @c SF_ALIGN_UP(size). Returns a pointer
* directly into @c g_arena; the caller must not @c free() the result.
* Returns NULL (cast 0) when the arena is exhausted or @c size is zero.
* Lazy-calls @c sf_alloc_init() if the arena has not yet been initialised.
*
* @param size Number of bytes to allocate; 0 returns NULL
* @return Pointer into the static arena, or NULL on exhaustion or zero size
*/
void* sf_malloc(size_t size)
{
if (!g_initialized) sf_alloc_init();
if (size == 0) return (void*)0;
size_t aligned_size = SF_ALIGN_UP(size);
size_t new_offset = g_arena_offset + aligned_size;
if (new_offset > SF_ARENA_SIZE)
{
/* Out of memory */
return (void*)0;
}
void* ptr = &g_arena[g_arena_offset];
g_arena_offset = new_offset;
g_stats.used_bytes = g_arena_offset;
g_stats.alloc_count++;
if (g_stats.used_bytes > g_stats.peak_bytes)
{
g_stats.peak_bytes = g_stats.used_bytes;
}
return ptr;
}
/*
* @brief Allocate a zero-initialised block of @c count * @c size bytes from the arena.
*
* Delegates to @c sf_malloc() then manually zeroes the result with a byte loop
* (no @c memset dependency — avoids linking the C runtime in freestanding builds).
* Guards against @c count*size overflow by verifying @c total/size == count.
*
* @param count Number of elements; 0 returns NULL
* @param size Size of each element in bytes; 0 returns NULL
* @return Pointer to zero-filled arena memory, or NULL on overflow/exhaustion/zero args
*/
void* sf_calloc(size_t count, size_t size)
{
if (count == 0 || size == 0) return (void*)0;
size_t total = count * size;
/* Check for overflow */
if (size != 0 && total / size != count)
{
return (void*)0;
}
void* ptr = sf_malloc(total);
if (ptr)
{
/* Zero-initialize */
uint8_t* p = (uint8_t*)ptr;
for (size_t i = 0; i < total; i++)
{
p[i] = 0;
}
}
return ptr;
}
/*
* @brief Resize an allocation — bump-allocator approximation.
*
* Because the arena does not store block sizes, the old block cannot be
* reclaimed. This function allocates a fresh block of @c new_size bytes and
* returns it; the old block is orphaned in the arena. The caller is responsible
* for copying any content from @c ptr to the returned pointer before discarding
* @c ptr. If @c ptr is NULL, behaves identically to @c sf_malloc(new_size).
*
* @param ptr Existing allocation (orphaned after this call); NULL is safe
* @param new_size Desired size in bytes; 0 returns NULL
* @return Pointer to a new arena block of at least @c new_size bytes, or NULL
*/
void* sf_realloc(void* ptr, size_t new_size)
{
/*
* Bump allocator limitation: we don't track allocation sizes.
* For kernel use, realloc is rarely needed.
*
* Strategy: allocate new block, caller must copy if needed.
* This wastes memory but works for rare realloc cases.
*
* If ptr is NULL, this is equivalent to malloc.
*/
if (!ptr) return sf_malloc(new_size);
if (new_size == 0) return (void*)0;
/* Allocate new block - old block is orphaned (bump allocator limitation) */
return sf_malloc(new_size);
}
/*
* @brief Release a block — no-op for the bump allocator.
*
* The kernel arena has no reclaim mechanism; memory is held until the
* next @c sf_alloc_init() call (i.e. the next power cycle). Increments
* @c g_stats.free_count so the caller can observe that @c sf_free() was
* invoked, but no bytes are returned to the arena.
*
* @param ptr Block to "free"; NULL is a safe no-op
*/
void sf_free(void* ptr)
{
/* Bump allocator: free is a no-op.
*
* This is acceptable because:
* 1. VM allocations happen at init time
* 2. VM runs until power-off
* 3. No fragmentation issues in practice
*
* If needed, could implement a simple free list here.
*/
if (ptr)
{
g_stats.free_count++;
}
(void)ptr;
}
/*
* @brief Copy the current arena statistics into @c stats.
*
* Fills @c *stats with a snapshot of @c g_stats. @c total_bytes is fixed at
* @c SF_ARENA_SIZE; @c used_bytes equals the current arena offset (exact,
* since no reclaim occurs); @c free_count tracks @c sf_free() call count
* even though no memory is actually released.
*
* @param stats Output buffer to populate; no-op if NULL
*/
void sf_alloc_get_stats(sf_alloc_stats_t* stats)
{
if (!stats) return;
*stats = g_stats;
}
v3/src/platform/l4re/README.md
+6
View File
@@ -0,0 +1,6 @@
# src/platform/l4re/
- `time.c` — HISTORICAL: L4Re/Fiasco.OC timing backend implementing
`include/platform_time.h`. L4Re was a supported platform target through
mid-2026; it has been removed as an active target, and this file is no
longer wired into any build (hosted or kernel).
v3/src/platform/l4re/time.c
+300
View File
@@ -0,0 +1,300 @@
/*
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.
*/
/*
* StarForth Platform Time - L4Re/StarshipOS Backend
*
* HISTORICAL: L4Re/Fiasco.OC was a supported platform target through
* mid-2026 (`make L4RE=1`). Removed as an active target -- no Makefile
* defines __l4__ anymore, so the entire body of this file is unreachable
* dead code. Retained for reference; see Makefile's "Platform support"
* section for the commented-out restoration path if L4Re support is ever
* revived.
*
* Implements platform time abstraction using L4Re RTC server and KIP clock.
*
* License: See LICENSE file
*/
#include "../../../include/platform_time.h"
#ifdef __l4__
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
/* L4Re headers */
#include <l4/sys/kip.h>
#include <l4/re/env.h>
#include <l4/rtc/rtc>
/* L4Re RTC capability (obtained at init) */
static L4::Cap<L4rtc::Rtc> rtc_cap = L4::Cap<L4rtc::Rtc>::Invalid;
static l4_uint64_t rtc_offset = 0; /* nanoseconds from 1970 to boot */
static int rtc_available = 0;
/* L4Re implementation */
/**
* @brief Return the current monotonic time in nanoseconds (L4Re build).
*
* Reads the KIP (Kernel Info Page) clock via @c l4_kip_clock_ns(). The KIP
* clock is a monotonic counter driven by the L4Re microkernel and is the
* standard high-resolution time source on L4Re. Returns 0 if the KIP pointer
* is unavailable (should never occur in a healthy L4Re environment).
*
* @return Nanoseconds since the L4Re epoch (system boot), or 0 on KIP error
*/
static sf_time_ns_t l4re_get_monotonic_ns(void) {
/* Use L4Re KIP clock: monotonic time since boot */
l4_kernel_info_t *kip = l4re_kip();
if (!kip) {
return 0; /* Fallback if KIP unavailable */
}
return l4_kip_clock_ns(kip);
}
/**
* @brief Return the current wall-clock time in nanoseconds since the Unix epoch (L4Re build).
*
* Combines the RTC offset (nanoseconds from epoch to system boot, obtained
* from the L4Re RTC server during @c sf_time_init_l4re()) with the current
* KIP clock value to produce an absolute timestamp. Falls back to monotonic
* time alone when @c rtc_available is 0, and to @c rtc_offset alone when
* the KIP pointer is unavailable.
*
* @return Nanoseconds since 1970-01-01 00:00:00 UTC, or approximate value on fallback
*/
static sf_time_ns_t l4re_get_realtime_ns(void) {
/* Use RTC server offset + KIP clock for wall-clock time */
if (!rtc_available) {
/* No RTC: return monotonic time (better than nothing) */
return l4re_get_monotonic_ns();
}
/* Real-time = RTC offset (ns since epoch to boot) + KIP clock (ns since boot) */
l4_kernel_info_t *kip = l4re_kip();
if (!kip) {
return rtc_offset; /* Fallback to RTC offset only */
}
return rtc_offset + l4_kip_clock_ns(kip);
}
/**
* @brief Set the system real-time clock via the L4Re RTC server (L4Re build).
*
* Computes the new RTC timer offset as @c ns_since_epoch minus the current
* KIP clock value, then calls @c rtc_cap->set_timer_offset() over IPC.
* On success, updates the cached @c rtc_offset. Returns -1 if the RTC
* capability is invalid, the KIP pointer is unavailable, or the IPC call
* fails.
*
* @param ns_since_epoch Desired wall-clock time in nanoseconds since Unix epoch
* @return 0 on success, -1 on any failure (no RTC capability, KIP error, IPC error)
*/
static int l4re_set_realtime_ns(sf_time_ns_t ns_since_epoch) {
if (!rtc_available || !rtc_cap.is_valid()) {
return -1; /* No RTC capability */
}
/* Calculate new offset: desired epoch time - current KIP clock */
l4_kernel_info_t *kip = l4re_kip();
if (!kip) {
return -1;
}
l4_uint64_t kip_ns = l4_kip_clock_ns(kip);
l4_uint64_t new_offset = ns_since_epoch - kip_ns;
/* Set RTC offset via IPC */
long ret = rtc_cap->set_timer_offset(new_offset);
if (ret < 0) {
return -1;
}
/* Update cached offset */
rtc_offset = new_offset;
return 0;
}
/**
* @brief Format a nanosecond-precision wall-clock time as a human-readable string (L4Re build).
*
* Converts @c ns_since_epoch to a @c time_t, calls @c localtime() and
* @c strftime() using the L4Re libc. Unlike the Linux backend, this variant
* uses a full date+time format (@c "%Y-%m-%d %H:%M:%S" or @c "%Y-%m-%d %I:%M:%S %p")
* rather than time-only. On @c localtime() failure, writes the raw second count as
* a decimal fallback and returns -1.
*
* @param ns_since_epoch Wall-clock time in nanoseconds since Unix epoch
* @param buf Output buffer (at least @c SF_TIME_STAMP_SIZE bytes); must not be NULL
* @param format_24h Non-zero for 24-hour format, zero for 12-hour with AM/PM
* @return 0 on success, -1 if @c buf is NULL or time formatting fails
*/
static int l4re_format_timestamp(sf_time_ns_t ns_since_epoch, char *buf, int format_24h) {
if (!buf) {
return -1;
}
/* Convert nanoseconds to seconds for libc time functions */
time_t seconds = (time_t)(ns_since_epoch / 1000000000ULL);
/* Use L4Re libc localtime + strftime */
struct tm *tm_info = localtime(&seconds);
if (!tm_info) {
/* Fallback: show raw seconds */
snprintf(buf, SF_TIME_STAMP_SIZE, "%llu", (unsigned long long) seconds);
return -1;
}
/* Format timestamp based on 24h preference */
const char *format = format_24h ? "%Y-%m-%d %H:%M:%S" : "%Y-%m-%d %I:%M:%S %p";
size_t ret = strftime(buf, SF_TIME_STAMP_SIZE, format, tm_info);
return (ret > 0) ? 0 : -1;
}
/**
* @brief Report whether an RTC is available (L4Re build).
*
* Returns the @c rtc_available flag set during @c sf_time_init_l4re().
* A value of 0 means the RTC IPC capability was absent or its offset query
* failed; wall-clock functions will return monotonic time as a fallback.
*
* @return 1 if the L4Re RTC server is reachable and its offset was obtained, 0 otherwise
*/
static int l4re_has_rtc(void) {
return rtc_available;
}
/* L4Re backend vtable */
const sf_time_backend_t sf_time_backend_l4re = {
.get_monotonic_ns = l4re_get_monotonic_ns,
.get_realtime_ns = l4re_get_realtime_ns,
.set_realtime_ns = l4re_set_realtime_ns,
.format_timestamp = l4re_format_timestamp,
.has_rtc = l4re_has_rtc,
};
/**
* @brief Initialise the L4Re time backend — acquire RTC capability and fetch epoch offset.
*
* Called once from @c sf_time_init() on L4Re builds. Attempts to obtain the
* @c "rtc" capability from the L4Re environment, then queries the RTC server
* for its timer offset (nanoseconds from the Unix epoch to the system boot
* time). On success sets @c rtc_available = 1 and caches @c rtc_offset.
* On any failure (missing capability, IPC error) sets @c rtc_available = 0
* and @c rtc_offset = 0, leaving the backend in monotonic-only mode.
* Diagnostic messages are printed to @c stderr throughout.
*
* @note Defined only when @c __l4__ is set; compiles to a no-op stub otherwise.
*/
void sf_time_init_l4re(void) {
fprintf(stderr, "[L4Re Time] Initializing L4Re time backend...\n");
/* Try to get RTC capability from L4Re environment */
rtc_cap = L4Re::Env::env()->get_cap<L4rtc::Rtc>("rtc");
if (!rtc_cap.is_valid()) {
fprintf(stderr, "[L4Re Time] WARNING: RTC capability not available\n");
fprintf(stderr, "[L4Re Time] Falling back to monotonic-only mode\n");
fprintf(stderr, "[L4Re Time] Real-time will use KIP clock (time since boot)\n");
rtc_available = 0;
rtc_offset = 0;
return;
}
/* RTC capability acquired successfully */
fprintf(stderr, "[L4Re Time] RTC capability acquired\n");
/* Query the RTC timer offset (nanoseconds from epoch to boot) */
long ret = rtc_cap->get_timer_offset(&rtc_offset);
if (ret < 0) {
fprintf(stderr, "[L4Re Time] ERROR: Failed to get RTC timer offset (ret=%ld)\n", ret);
fprintf(stderr, "[L4Re Time] RTC may not be initialized or running\n");
fprintf(stderr, "[L4Re Time] Setting offset to 0 (will show time since boot as epoch)\n");
rtc_available = 0;
rtc_offset = 0;
return;
}
/* Success! */
rtc_available = 1;
fprintf(stderr, "[L4Re Time] RTC offset retrieved: %llu ns since epoch\n",
(unsigned long long) rtc_offset);
/* Convert offset to a readable date for verification */
time_t boot_time_sec = (time_t)(rtc_offset / 1000000000ULL);
struct tm *boot_tm = gmtime(&boot_time_sec);
if (boot_tm) {
char boot_str[64];
strftime(boot_str, sizeof(boot_str), "%Y-%m-%d %H:%M:%S UTC", boot_tm);
fprintf(stderr, "[L4Re Time] System boot time: %s\n", boot_str);
}
/* Display current time */
l4_kernel_info_t *kip = l4re_kip();
if (kip) {
l4_uint64_t now_ns = rtc_offset + l4_kip_clock_ns(kip);
time_t now_sec = (time_t)(now_ns / 1000000000ULL);
struct tm *now_tm = gmtime(&now_sec);
if (now_tm) {
char now_str[64];
strftime(now_str, sizeof(now_str), "%Y-%m-%d %H:%M:%S UTC", now_tm);
fprintf(stderr, "[L4Re Time] Current time: %s\n", now_str);
}
}
fprintf(stderr, "[L4Re Time] Initialization complete\n");
}
#else
/* Dummy implementation when not building for L4Re */
const sf_time_backend_t sf_time_backend_l4re = {0};
void sf_time_init_l4re(void) {
}
#endif /* __l4__ */
v3/src/platform/linux/README.md
+4
View File
@@ -0,0 +1,4 @@
# src/platform/linux/
- `time.c` — POSIX timing backend (`clock_gettime`) for the hosted Linux
build; implements `include/platform_time.h`.
v3/src/platform/linux/io.c
+49
View File
@@ -0,0 +1,49 @@
/*
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 Platform IO - Linux/POSIX Backend
*
* Implements platform_io.h's terminal-readiness check using select() on
* fd 0, the standard POSIX non-blocking-stdin-peek idiom. Zero timeout:
* a single poll, never blocks.
*
* License: See LICENSE file
*/
#include "../../../include/platform_io.h"
#include <sys/select.h>
#include <unistd.h>
int sf_terminal_ready(void) {
fd_set readfds;
struct timeval tv;
FD_ZERO(&readfds);
FD_SET(STDIN_FILENO, &readfds);
tv.tv_sec = 0;
tv.tv_usec = 0;
int r = select(STDIN_FILENO + 1, &readfds, NULL, NULL, &tv);
return (r > 0 && FD_ISSET(STDIN_FILENO, &readfds)) ? 1 : 0;
}
v3/src/platform/linux/time.c
+172
View File
@@ -0,0 +1,172 @@
/*
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.
*/
/*
* StarForth Platform Time - Linux/POSIX Backend
*
* Implements platform time abstraction using POSIX clock_gettime().
*
* License: See LICENSE file
*/
#define _POSIX_C_SOURCE 199309L
#include "../../../include/platform_time.h"
#include <stdio.h>
#include <time.h>
#include <string.h>
/* POSIX implementation */
/**
* @brief Return the current monotonic time in nanoseconds.
*
* Reads @c CLOCK_MONOTONIC via @c clock_gettime(). The clock advances
* continuously and is unaffected by wall-clock adjustments — suitable for
* measuring elapsed durations such as execution latency and decay intervals.
* Returns 0 on @c clock_gettime() failure (should not occur on any modern
* POSIX kernel).
*
* @return Nanoseconds since an arbitrary but fixed epoch, or 0 on error
*/
static sf_time_ns_t posix_get_monotonic_ns(void) {
struct timespec ts;
if (clock_gettime(CLOCK_MONOTONIC, &ts) != 0)
return 0;
return (sf_time_ns_t) ts.tv_sec * 1000000000ULL + (sf_time_ns_t) ts.tv_nsec;
}
/**
* @brief Return the current wall-clock time in nanoseconds since the Unix epoch.
*
* Reads @c CLOCK_REALTIME via @c clock_gettime(). Subject to NTP or @c settimeofday()
* adjustments — use @c posix_get_monotonic_ns() for interval timing.
* Returns 0 on @c clock_gettime() failure.
*
* @return Nanoseconds since 1970-01-01 00:00:00 UTC, or 0 on error
*/
static sf_time_ns_t posix_get_realtime_ns(void) {
struct timespec ts;
if (clock_gettime(CLOCK_REALTIME, &ts) != 0)
return 0;
return (sf_time_ns_t) ts.tv_sec * 1000000000ULL + (sf_time_ns_t) ts.tv_nsec;
}
/**
* @brief Set the system real-time clock to @c ns_since_epoch.
*
* Converts @c ns_since_epoch to a @c struct timespec and calls
* @c clock_settime(CLOCK_REALTIME). Requires @c CAP_SYS_TIME or equivalent
* privilege; fails with @c EPERM if the caller lacks permission.
*
* @param ns_since_epoch Desired new wall-clock time in nanoseconds since Unix epoch
* @return 0 on success, non-zero errno-encoded error on failure
*/
static int posix_set_realtime_ns(sf_time_ns_t ns_since_epoch) {
struct timespec ts;
ts.tv_sec = (time_t)(ns_since_epoch / 1000000000ULL);
ts.tv_nsec = (long) (ns_since_epoch % 1000000000ULL);
return clock_settime(CLOCK_REALTIME, &ts);
}
/**
* @brief Format a nanosecond-precision wall-clock time as a human-readable string.
*
* Converts @c ns_since_epoch to local time, formats hours/minutes/seconds via
* @c strftime(), then appends a three-digit millisecond suffix. The result is
* written into @c buf (must be at least @c SF_TIME_STAMP_SIZE bytes). On
* @c localtime() or @c strftime() failure, writes @c "??:??:??.???" into @c buf
* and returns -1.
*
* @param ns_since_epoch Wall-clock time in nanoseconds since Unix epoch
* @param buf Output buffer (at least @c SF_TIME_STAMP_SIZE bytes); must not be NULL
* @param format_24h Non-zero for 24-hour format (@c %H:%M:%S), zero for 12-hour (@c %I:%M:%S %p)
* @return 0 on success, -1 if @c buf is NULL or time formatting fails
*/
static int posix_format_timestamp(sf_time_ns_t ns_since_epoch, char *buf, int format_24h) {
if (!buf)
return -1;
time_t seconds = (time_t)(ns_since_epoch / 1000000000ULL);
unsigned int ms = (unsigned int)((ns_since_epoch % 1000000000ULL) / 1000000ULL);
struct tm *tm_info = localtime(&seconds);
if (!tm_info) {
strncpy(buf, "??:??:??.???", SF_TIME_STAMP_SIZE - 1);
buf[SF_TIME_STAMP_SIZE - 1] = '\0';
return -1;
}
char hms[16];
const char *format = format_24h ? "%H:%M:%S" : "%I:%M:%S %p";
if (strftime(hms, sizeof(hms), format, tm_info) == 0) {
strncpy(buf, "??:??:??.???", SF_TIME_STAMP_SIZE - 1);
buf[SF_TIME_STAMP_SIZE - 1] = '\0';
return -1;
}
snprintf(buf, SF_TIME_STAMP_SIZE, "%s.%03u", hms, ms);
return 0;
}
/**
* @brief Probe whether a real-time clock is available.
*
* Attempts a @c clock_gettime(CLOCK_REALTIME) probe. POSIX systems invariably
* support @c CLOCK_REALTIME so this will return 1 in practice; the check
* mirrors the bare-metal backend's interface where RTC presence is genuinely
* uncertain.
*
* @return 1 if @c CLOCK_REALTIME is readable, 0 otherwise
*/
static int posix_has_rtc(void) {
/* POSIX systems typically have working CLOCK_REALTIME */
struct timespec ts;
return (clock_gettime(CLOCK_REALTIME, &ts) == 0) ? 1 : 0;
}
/* POSIX backend vtable */
const sf_time_backend_t sf_time_backend_posix = {
.get_monotonic_ns = posix_get_monotonic_ns,
.get_realtime_ns = posix_get_realtime_ns,
.set_realtime_ns = posix_set_realtime_ns,
.format_timestamp = posix_format_timestamp,
.has_rtc = posix_has_rtc,
};
v3/src/platform/platform_init.c
+85
View File
@@ -0,0 +1,85 @@
/*
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.
*/
/*
* StarForth Platform Initialization
*
* Selects and initializes the appropriate platform backend based on build configuration.
*
* License: See LICENSE file
*/
#include "../../include/platform_time.h"
/* Global backend pointer (starts as NULL) */
const sf_time_backend_t *sf_time_backend = NULL;
/* HISTORICAL: L4Re-specific init (defined in src/platform/l4re/time.c,
* retained but no longer wired into any build). L4Re support has been
* removed as an active target.
* #ifdef __l4__
* extern void sf_time_init_l4re(void);
* #endif
*/
/**
* @brief Initialize platform time subsystem
*
* Selects the POSIX backend (clock_gettime()). Call this once at program
* startup before using any time functions.
*/
void sf_time_init(void) {
if (sf_time_backend != NULL)
return; /* Already initialized */
/* HISTORICAL: an #ifdef __l4__ branch here called sf_time_init_l4re()
* and selected sf_time_backend_l4re. L4Re support has been removed as
* an active target.
* #ifdef __l4__
* sf_time_init_l4re();
* sf_time_backend = &sf_time_backend_l4re;
* #else
*/
/* POSIX build */
sf_time_backend = &sf_time_backend_posix;
/* #endif -- matches the commented-out #ifdef __l4__ above */
}
v3/src/platform/threading.c
+202
View File
@@ -0,0 +1,202 @@
/*
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.
*/
/*
* platform/threading.c - Minimal mutex abstraction bridging POSIX and
* embedded (spinlock-based) targets
*/
#include "../../include/platform_lock.h"
/* HISTORICAL: these two conditions also referenced L4RE_TARGET
* (`&& !defined(L4RE_TARGET)` / `|| defined(L4RE_TARGET)`) -- L4Re had no
* pthreads either, so it shared the spinlock path with STARFORTH_MINIMAL.
* L4Re support has been removed as an active target. */
#if !defined(STARFORTH_MINIMAL)
#include <pthread.h>
#endif
#if defined(STARFORTH_MINIMAL)
/* Spinlock-based mutex for minimal/embedded builds */
/**
* @brief Initialise a spinlock mutex (minimal build).
*
* Sets @c mutex->state to 0 (unlocked). Safe to call on a mutex that has
* already been destroyed. On embedded targets where @c pthread is unavailable,
* this replaces @c pthread_mutex_init().
*
* @param mutex Mutex to initialise; returns -1 if NULL
* @return 0 on success, -1 if @c mutex is NULL
*/
int sf_mutex_init(sf_mutex_t *mutex)
{
if (!mutex) return -1;
mutex->state = 0;
return 0;
}
/**
* @brief Destroy a spinlock mutex (minimal build).
*
* Resets @c mutex->state to 0. No resources are released because the
* spinlock uses only the single @c state field. Safe to call on an
* already-destroyed mutex.
*
* @param mutex Mutex to destroy; no-op if NULL
*/
void sf_mutex_destroy(sf_mutex_t *mutex)
{
if (!mutex) return;
mutex->state = 0;
}
/**
* @brief Acquire a spinlock mutex (minimal build).
*
* Busy-waits using @c __sync_lock_test_and_set() until the lock is obtained.
* Issues an architecture-appropriate yield hint (@c PAUSE on x86,
* @c YIELD on ARM/AArch64, @c NOP on RISC-V) inside the spin loop to
* reduce power consumption and SMT contention.
*
* @param mutex Mutex to lock; no-op if NULL
*/
void sf_mutex_lock(sf_mutex_t *mutex)
{
if (!mutex) return;
while (__sync_lock_test_and_set(&mutex->state, 1))
{
/* CPU yield to reduce power consumption and improve performance */
#if defined(__x86_64__) || defined(__i386__) || defined(_M_X64) || defined(_M_IX86)
/* x86/x86_64: PAUSE instruction reduces pipeline flush penalty */
__asm__ __volatile__("pause" ::: "memory");
#elif defined(__aarch64__) || defined(__arm__)
/* ARM/AArch64: YIELD hint for SMT threads */
__asm__ __volatile__("yield" ::: "memory");
#elif defined(__riscv)
/* RISC-V: NOP as yield hint */
__asm__ __volatile__("nop" ::: "memory");
#else
/* Fallback: compiler barrier prevents optimization */
__asm__ __volatile__("" ::: "memory");
#endif
}
}
/**
* @brief Release a spinlock mutex (minimal build).
*
* Clears the lock state atomically using @c __sync_lock_release(), which
* implies a full memory barrier on all supported architectures. Threads
* blocked in @c sf_mutex_lock() will observe the release on their next
* test-and-set iteration.
*
* @param mutex Mutex to unlock; no-op if NULL
*/
void sf_mutex_unlock(sf_mutex_t *mutex)
{
if (!mutex) return;
__sync_lock_release(&mutex->state);
}
#else /* POSIX */
/**
* @brief Initialise a POSIX mutex (hosted build).
*
* Delegates to @c pthread_mutex_init() with default attributes.
*
* @param mutex Mutex to initialise; returns -1 if NULL
* @return 0 on success, -1 if @c mutex is NULL, or a positive @c errno value
* propagated from @c pthread_mutex_init()
*/
int sf_mutex_init(sf_mutex_t *mutex)
{
if (!mutex) return -1;
return pthread_mutex_init(&mutex->handle, NULL);
}
/**
* @brief Destroy a POSIX mutex (hosted build).
*
* Delegates to @c pthread_mutex_destroy(). The mutex must not be locked
* when destroyed. Return value is discarded; callers that need the error
* code should call @c pthread_mutex_destroy() directly.
*
* @param mutex Mutex to destroy; no-op if NULL
*/
void sf_mutex_destroy(sf_mutex_t *mutex)
{
if (!mutex) return;
pthread_mutex_destroy(&mutex->handle);
}
/**
* @brief Acquire a POSIX mutex (hosted build).
*
* Delegates to @c pthread_mutex_lock(). Blocks until the mutex is available.
* Return value is discarded; a locking error will manifest as a deadlock or
* data race, not a silent failure.
*
* @param mutex Mutex to lock; no-op if NULL
*/
void sf_mutex_lock(sf_mutex_t *mutex)
{
if (!mutex) return;
pthread_mutex_lock(&mutex->handle);
}
/**
* @brief Release a POSIX mutex (hosted build).
*
* Delegates to @c pthread_mutex_unlock(). Must be called by the same thread
* that acquired the lock. Return value is discarded.
*
* @param mutex Mutex to unlock; no-op if NULL
*/
void sf_mutex_unlock(sf_mutex_t *mutex)
{
if (!mutex) return;
pthread_mutex_unlock(&mutex->handle);
}
#endif
v3/src/profiler.c
+530
View File
@@ -0,0 +1,530 @@
/*
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.
*/
/**
* @file profiler.c
* @brief Performance profiling implementation for StarForth
*
* This module implements performance profiling functionality for the StarForth virtual machine.
* It tracks execution statistics including:
* - Word execution counts and timing
* - Dictionary lookup frequency
* - Stack operations
* - Memory usage patterns
*
* The profiler supports multiple detail levels from basic to verbose profiling.
*/
#define _POSIX_C_SOURCE 199309L
#include "../include/profiler.h"
#include "../include/platform_time.h"
#include "../include/vm.h"
#include "../include/physics_metadata.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
/* Forward declare DictEntry */
typedef struct DictEntry DictEntry;
/**
* @brief Statistics for individual word execution
*/
typedef struct {
const DictEntry *entry; /**< Pointer to dictionary entry */
uint64_t call_count; /**< Number of times word was called */
uint64_t total_time_ns; /**< Total execution time in nanoseconds */
uint64_t min_time_ns; /**< Minimum execution time in nanoseconds */
uint64_t max_time_ns; /**< Maximum execution time in nanoseconds */
} WordStats;
/* Global profiler state */
static struct {
ProfileLevel level;
int enabled;
/* Word execution tracking */
WordStats *word_stats;
size_t word_count;
size_t word_capacity;
/* Current word timing */
const char *current_word;
uint64_t current_start_time;
/* Global counters */
uint64_t total_dict_lookups;
uint64_t total_stack_ops;
uint64_t total_memory_reads;
uint64_t total_memory_writes;
} profiler_state = {0};
void *g_profiler = &profiler_state;
/**
* @brief Get current time in nanoseconds
* @return Current time in nanoseconds from monotonic clock
*/
static uint64_t get_time_ns(void) {
/* Use platform abstraction for monotonic time */
return sf_monotonic_ns();
}
/**
* @brief Safely print a word name, handling non-null-terminated names
* @param entry Dictionary entry whose name to print
*/
static void print_word_name_safe(const DictEntry *entry) {
if (!entry) {
printf("<null>");
return;
}
for (size_t i = 0; i < entry->name_len && i < 32; i++) {
putchar((unsigned char) entry->name[i]);
}
}
/*
* @brief Initialize the profiler subsystem
* @param level Profiling detail level to enable
* @return 0 on success, -1 on failure
*/
int profiler_init(ProfileLevel level) {
if (level == PROFILE_DISABLED) {
return 0;
}
profiler_state.level = level;
profiler_state.enabled = 1;
/* Allocate initial word stats array */
profiler_state.word_capacity = 256;
profiler_state.word_stats = calloc(profiler_state.word_capacity, sizeof(WordStats));
if (!profiler_state.word_stats) {
profiler_state.enabled = 0;
return -1;
}
profiler_state.word_count = 0;
profiler_state.total_dict_lookups = 0;
profiler_state.total_stack_ops = 0;
profiler_state.total_memory_reads = 0;
profiler_state.total_memory_writes = 0;
return 0;
}
/**
* @brief Shutdown the profiler and free resources
*/
void profiler_shutdown(void) {
if (profiler_state.word_stats) {
free(profiler_state.word_stats);
profiler_state.word_stats = NULL;
}
profiler_state.enabled = 0;
profiler_state.word_count = 0;
}
/**
* @brief Find or create statistics entry for a word
* @param entry Dictionary entry to find/create stats for
* @return Pointer to word stats or NULL if not found/created
*/
static WordStats *get_word_stats(const DictEntry *entry) {
if (!profiler_state.enabled || !entry) return NULL;
/* Search for existing entry - compare by pointer address since
DictEntry pointers are stable for the lifetime of the word */
for (size_t i = 0; i < profiler_state.word_count; i++) {
if (profiler_state.word_stats[i].entry == entry) {
return &profiler_state.word_stats[i];
}
}
/* Create new entry if space available */
if (profiler_state.word_count < profiler_state.word_capacity) {
WordStats *stats = &profiler_state.word_stats[profiler_state.word_count++];
stats->entry = entry;
stats->call_count = 0;
stats->total_time_ns = 0;
stats->min_time_ns = UINT64_MAX;
stats->max_time_ns = 0;
return stats;
}
return NULL;
}
/*
* @brief Record entry into a word for profiling
* @param entry Dictionary entry being entered
*/
void profiler_word_enter(const DictEntry *entry) {
if (!profiler_state.enabled || profiler_state.level < PROFILE_DETAILED) return;
if (!entry) return;
profiler_state.current_word = (const char *) entry;
profiler_state.current_start_time = get_time_ns();
}
/*
* @brief Record exit from a word for profiling
* @param entry Dictionary entry being exited
*/
void profiler_word_exit(const DictEntry *entry) {
if (!profiler_state.enabled || profiler_state.level < PROFILE_DETAILED) return;
if (!entry || !profiler_state.current_word) return;
uint64_t elapsed = get_time_ns() - profiler_state.current_start_time;
WordStats *stats = get_word_stats(entry);
if (stats) {
stats->call_count++;
stats->total_time_ns += elapsed;
if (elapsed < stats->min_time_ns) stats->min_time_ns = elapsed;
if (elapsed > stats->max_time_ns) stats->max_time_ns = elapsed;
}
physics_metadata_record_latency((DictEntry *) entry, elapsed);
profiler_state.current_word = NULL;
}
/*
* @brief Track word execution frequency without timing overhead
* @param entry Dictionary entry being executed
*
* This is a lightweight alternative to profiler_word_enter/exit that only
* tracks execution counts without timing. Use for PROFILE_BASIC level.
*/
void profiler_word_count(const DictEntry *entry) {
if (!profiler_state.enabled || !entry) return;
if (profiler_state.level >= PROFILE_DETAILED) return;
WordStats *stats = get_word_stats(entry);
if (stats) {
stats->call_count++;
}
}
/* Increment counters */
void profiler_inc_dict_lookup(void) {
if (profiler_state.enabled && profiler_state.level >= PROFILE_BASIC) {
profiler_state.total_dict_lookups++;
}
}
void profiler_inc_stack_op(void) {
if (profiler_state.enabled && profiler_state.level >= PROFILE_VERBOSE) {
profiler_state.total_stack_ops++;
}
}
void profiler_memory_read(size_t bytes) {
if (profiler_state.enabled && profiler_state.level >= PROFILE_VERBOSE) {
profiler_state.total_memory_reads += bytes;
}
}
void profiler_memory_write(size_t bytes) {
if (profiler_state.enabled && profiler_state.level >= PROFILE_VERBOSE) {
profiler_state.total_memory_writes += bytes;
}
}
/**
* @brief Compare two WordStats entries by total execution time
* @param a First WordStats entry to compare
* @param b Second WordStats entry to compare
* @return -1, 0, or 1 for qsort ordering
*/
static int compare_by_time(const void *a, const void *b) {
const WordStats *wa = (const WordStats *) a;
const WordStats *wb = (const WordStats *) b;
if (wb->total_time_ns > wa->total_time_ns) return 1;
if (wb->total_time_ns < wa->total_time_ns) return -1;
return 0;
}
/**
* @brief Compare two WordStats entries by call count
* @param a First WordStats entry to compare
* @param b Second WordStats entry to compare
* @return -1, 0, or 1 for qsort ordering
*/
static int compare_by_calls(const void *a, const void *b) {
const WordStats *wa = (const WordStats *) a;
const WordStats *wb = (const WordStats *) b;
if (wb->call_count > wa->call_count) return 1;
if (wb->call_count < wa->call_count) return -1;
return 0;
}
/**
* @brief Generate and print detailed profiling report
*
* Generates a report including:
* - Global statistics (dictionary lookups, stack ops, memory usage)
* - Top words by execution time
* - Most frequently called words
*/
void profiler_generate_report(void) {
if (!profiler_state.enabled) {
printf("Profiler not enabled\n");
return;
}
printf("\n");
printf("========================================\n");
printf(" StarForth Profiler Report\n");
printf("========================================\n\n");
/* Global statistics */
if (profiler_state.level >= PROFILE_BASIC) {
printf("Global Statistics:\n");
printf(" Dictionary lookups: %lu\n", (unsigned long) profiler_state.total_dict_lookups);
if (profiler_state.level >= PROFILE_VERBOSE) {
printf(" Stack operations: %lu\n", (unsigned long) profiler_state.total_stack_ops);
printf(" Memory reads: %lu bytes\n", (unsigned long) profiler_state.total_memory_reads);
printf(" Memory writes: %lu bytes\n", (unsigned long) profiler_state.total_memory_writes);
}
printf("\n");
}
/* Word execution statistics */
if (profiler_state.word_count > 0) {
if (profiler_state.level >= PROFILE_DETAILED) {
/* Detailed mode: show timing info */
printf("Top Words by Execution Time:\n");
printf("%-20s %10s %15s %12s %12s\n", "Word", "Calls", "Total (µs)", "Avg (ns)", "Max (ns)");
printf("--------------------------------------------------------------------------------\n");
/* Sort by total time */
qsort(profiler_state.word_stats, profiler_state.word_count,
sizeof(WordStats), compare_by_time);
/* Show top 20 */
size_t limit = profiler_state.word_count < 20 ? profiler_state.word_count : 20;
for (size_t i = 0; i < limit; i++) {
WordStats *s = &profiler_state.word_stats[i];
if (s->call_count > 0) {
uint64_t avg_ns = s->total_time_ns / s->call_count;
print_word_name_safe(s->entry);
/* Pad to 20 characters */
size_t name_len = s->entry ? s->entry->name_len : 0;
for (size_t j = name_len; j < 20; j++) putchar(' ');
printf(" %10lu %15.2f %12lu %12lu\n",
(unsigned long) s->call_count,
s->total_time_ns / 1000.0,
(unsigned long) avg_ns,
(unsigned long) s->max_time_ns);
}
}
printf("\n");
}
/* Show frequency data for all levels >= BASIC */
if (profiler_state.level >= PROFILE_BASIC) {
printf("Most Frequently Called Words:\n");
printf("%-20s %10s\n", "Word", "Calls");
printf("----------------------------------------\n");
qsort(profiler_state.word_stats, profiler_state.word_count,
sizeof(WordStats), compare_by_calls);
size_t limit = profiler_state.word_count < 15 ? profiler_state.word_count : 15;
for (size_t i = 0; i < limit; i++) {
WordStats *s = &profiler_state.word_stats[i];
if (s->call_count > 0) {
print_word_name_safe(s->entry);
/* Pad to 20 characters */
size_t name_len = s->entry ? s->entry->name_len : 0;
for (size_t j = name_len; j < 20; j++) putchar(' ');
printf(" %10lu\n", (unsigned long) s->call_count);
}
}
printf("\n");
}
}
printf("========================================\n\n");
}
/* Stub implementations for unused functions */
void profiler_reset(void) {
if (!profiler_state.enabled) return;
/* Reset all counters */
for (size_t i = 0; i < profiler_state.word_count; i++) {
profiler_state.word_stats[i].call_count = 0;
profiler_state.word_stats[i].total_time_ns = 0;
profiler_state.word_stats[i].min_time_ns = UINT64_MAX;
profiler_state.word_stats[i].max_time_ns = 0;
}
profiler_state.total_dict_lookups = 0;
profiler_state.total_stack_ops = 0;
profiler_state.total_memory_reads = 0;
profiler_state.total_memory_writes = 0;
}
void profiler_set_level(ProfileLevel level) {
profiler_state.level = level;
}
uint64_t profiler_get_time_ns(void) {
return get_time_ns();
}
void profiler_start_timer(ProfileCategory category) { (void) category; }
void profiler_end_timer(ProfileCategory category) { (void) category; }
void profiler_memory_alloc(size_t bytes) { (void) bytes; }
void profiler_inc_vm_cycles(uint64_t cycles) { (void) cycles; }
void profiler_inc_branch(void) {
}
void profiler_inc_loop_iter(void) {
}
void profiler_print_summary(void) { profiler_generate_report(); }
/**
* @brief Print hot word analysis with optimization recommendations
*
* Analyzes word execution frequency and provides actionable recommendations
* for performance optimization including:
* - Assembly optimization candidates
* - Inlining opportunities
* - Cache-friendly ordering
*/
void profiler_print_hotspots(void) {
if (!profiler_state.enabled || profiler_state.word_count == 0) {
printf("No profiling data available\n");
return;
}
printf("\n");
printf("========================================\n");
printf(" Hot Word Analysis & Optimization\n");
printf("========================================\n\n");
/* Sort by call frequency */
qsort(profiler_state.word_stats, profiler_state.word_count,
sizeof(WordStats), compare_by_calls);
/* Calculate total calls for percentage */
uint64_t total_calls = 0;
for (size_t i = 0; i < profiler_state.word_count; i++) {
total_calls += profiler_state.word_stats[i].call_count;
}
if (total_calls == 0) {
printf("No word executions recorded\n");
return;
}
printf("Top 25 Most Frequently Called Words:\n");
printf("%-20s %12s %10s %s\n", "Word", "Calls", "% Total", "Optimization Suggestion");
printf("--------------------------------------------------------------------------------\n");
size_t limit = profiler_state.word_count < 25 ? profiler_state.word_count : 25;
for (size_t i = 0; i < limit; i++) {
WordStats *s = &profiler_state.word_stats[i];
if (s->call_count == 0) continue;
double pct = (s->call_count * 100.0) / total_calls;
/* Print word name */
print_word_name_safe(s->entry);
size_t name_len = s->entry ? s->entry->name_len : 0;
for (size_t j = name_len; j < 20; j++) putchar(' ');
printf(" %12lu %9.2f%% ", (unsigned long) s->call_count, pct);
/* Provide optimization suggestions based on frequency */
if (pct >= 5.0) {
printf("⚡ HIGH PRIORITY: Inline assembly candidate");
} else if (pct >= 2.0) {
printf("🔥 Consider assembly optimization");
} else if (pct >= 1.0) {
printf("💡 Monitor for optimization");
} else if (pct >= 0.5) {
printf("📊 Profile for PGO");
} else {
printf("—");
}
printf("\n");
}
printf("\n");
printf("Summary:\n");
printf(" Total word executions: %lu\n", (unsigned long) total_calls);
printf(" Unique words tracked: %lu\n", (unsigned long) profiler_state.word_count);
/* Calculate top 10 coverage */
uint64_t top10_calls = 0;
size_t top10_limit = profiler_state.word_count < 10 ? profiler_state.word_count : 10;
for (size_t i = 0; i < top10_limit; i++) {
top10_calls += profiler_state.word_stats[i].call_count;
}
double top10_pct = (top10_calls * 100.0) / total_calls;
printf(" Top 10 coverage: %.1f%%\n", top10_pct);
printf("\n========================================\n\n");
}
void profiler_print_word_analysis(void) {
profiler_print_hotspots();
}
void profiler_print_memory_analysis(void) {
}
void profiler_analyze_performance(VM *vm) { (void) vm; }
void profiler_suggest_optimizations(void) {
profiler_print_hotspots();
}
v3/src/repl.c
+144
View File
@@ -0,0 +1,144 @@
/*
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/repl.h"
#include "../include/log.h"
#include "../include/vm.h"
#include <stdio.h>
/**
* @brief Extension point for non-recoverable VM errors (weak symbol).
*
* Called by the REPL when @c EMERGENCY_CONSOLE_ENABLED = 0 and an error
* occurs. The default implementation logs the fault at @c LOG_ERROR level
* and sets @c vm->halted = 1, causing the REPL loop to exit cleanly.
*
* Platforms that need hardware reset, watchdog kick, or JTAG debug-probe
* integration should provide a strong definition in a platform-specific file
* (e.g., @c starkernel/hal/fault.c) to override this weak default.
*
* @param vm Active VM whose @c vm->error triggered the fault path
*/
__attribute__((weak)) void vm_fault_handler(VM *vm) {
log_message(LOG_ERROR, "VM fault — emergency console disabled; halting");
vm->halted = 1;
}
/**
* @brief Starts the Forth REPL (Read-Eval-Print Loop)
*
* @param vm Pointer to the VM structure
* @param script_mode If 1, suppress prompts and "ok" output (for piped input)
*
* @details This function implements an interactive REPL for the Forth interpreter.
* It continuously reads input from the user, interprets it, and prints the result
* until the VM is halted or an error occurs.
*
* In interactive mode (script_mode=0):
* - Prints colored prompt "ok> "
* - Acknowledges successful commands with " ok"
* - Reports errors with " ERROR"
*
* In script mode (script_mode=1):
* - Suppresses all prompts and status messages
* - Suitable for piped input (heredoc, pipes, redirects)
*/
void vm_repl(VM *vm, int script_mode) {
if (!script_mode) {
log_message(LOG_INFO, "Starting Forth REPL");
}
char input[256];
while (!vm->halted && !vm->error) {
/* Print prompt only in interactive mode */
if (!script_mode) {
if (vm->zuse_session)
printf("\033[36mzuse)ok>\033[0m \033[92m");
else
printf("\033[36mok>\033[0m \033[92m");
fflush(stdout);
}
if (!fgets(input, sizeof(input), stdin)) {
if (!script_mode) {
printf("\033[0m");
fflush(stdout);
}
break;
}
if (!script_mode) {
printf("\033[0m");
fflush(stdout);
}
vm_interpret(vm, input);
/* ABORT stops mid-line (see vm_interpret/execute_colon_word) but the
* flag is left set for the caller to consume -- this REPL line is
* that boundary. Clear it here so the next line isn't silently
* refused by vm_interpret's own abort_requested check. */
vm->abort_requested = 0;
if (!script_mode) {
/* Print status only in interactive mode */
if (!vm->error) {
printf(" ok\n");
} else {
printf(" ERROR\n");
#if EMERGENCY_CONSOLE_ENABLED
vm->error = 0; /* recover: allow next input */
#else
vm_fault_handler(vm); /* non-recoverable: extension point */
#endif
}
} else {
if (vm->error) {
#if EMERGENCY_CONSOLE_ENABLED
vm->error = 0;
#else
vm_fault_handler(vm);
#endif
}
}
}
}
v3/src/rolling_window_of_truth.c
+1353
View File
File diff suppressed because it is too large Load Diff
v3/src/ssm_jacquard.c
+482
View File
@@ -0,0 +1,482 @@
/*
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 "ssm_jacquard.h"
#include <string.h>
#include <stdlib.h>
/* ============================================================================
* L8 Initialization
* ============================================================================
*/
/**
* @brief Initialise the L8 Jacquard steady-state machine.
*
* Sets @c current_mode and @c pending_mode to @c initial_mode, zeroes
* @c hysteresis_counter, and sets @c table to NULL. Callers must invoke
* @c ssm_l8_init_table() separately if the adaptive UCB table is required.
*
* @param state Pointer to the L8 state to initialise
* @param initial_mode Starting mode (typically @c SSM_MODE_C0)
*/
void ssm_l8_init(ssm_l8_state_t *state, ssm_l8_mode_t initial_mode)
{
if (!state) return;
state->current_mode = initial_mode;
state->hysteresis_counter = 0;
state->pending_mode = initial_mode;
state->table = NULL; /* Caller calls ssm_l8_init_table() separately */
}
/* ============================================================================
* L8 Mode Selection Logic (Data-Driven from Top 5% DoE Analysis)
* ============================================================================
*/
/**
* @brief Update the L8 mode selector using current runtime metrics.
*
* Classifies @c metrics into four binary feature bits (L2/L3/L5/L6) derived
* from DoE top-5% analysis and computes a target mode. Applies hysteresis:
* the mode only commits after @c SSM_HYSTERESIS_TICKS consecutive ticks with
* the same target. Called by the heartbeat thread on every tick.
*
* @param metrics Runtime metrics snapshot (entropy, CV, temporal decay)
* @param state L8 state to update; @c current_mode is written on commit
*/
void ssm_l8_update(const ssm_l8_metrics_t *metrics, ssm_l8_state_t *state)
{
if (!metrics || !state) return;
/* Classify metrics into binary features */
int entropy_high = (metrics->entropy >= SSM_ENTROPY_HIGH_THRESHOLD);
int cv_high = (metrics->cv >= SSM_CV_HIGH_THRESHOLD);
int temporal_high = (metrics->temporal_decay >= SSM_TEMPORAL_DECAY_THRESHOLD);
int temporal_med = (metrics->temporal_decay >= SSM_TEMPORAL_DECAY_LOW_THRESHOLD);
/* Determine target mode using 4-bit logic (L2 L3 L5 L6) */
ssm_l8_mode_t target_mode = SSM_MODE_C0; /* Default: minimal */
/* L2 bit: Enable rolling window if high entropy (diversity) */
int L2_bit = entropy_high ? 1 : 0;
/* L3 bit: Enable linear decay if high temporal locality */
int L3_bit = temporal_high ? 1 : 0;
/* L5 bit: Enable window inference if high CV (volatility) */
int L5_bit = cv_high ? 1 : 0;
/* L6 bit: Enable decay inference if CV high AND moderate temporal */
int L6_bit = (cv_high && temporal_med) ? 1 : 0;
/* Combine bits into mode selector: L2 L3 L5 L6 */
target_mode = (ssm_l8_mode_t)((L2_bit << 3) | (L3_bit << 2) | (L5_bit << 1) | L6_bit);
/* Hysteresis: only change mode after SSM_HYSTERESIS_TICKS consecutive votes */
if (target_mode == state->pending_mode) {
/* Same target as last time, increment counter */
state->hysteresis_counter++;
if (state->hysteresis_counter >= SSM_HYSTERESIS_TICKS) {
/* Threshold reached, commit mode change */
if (target_mode != state->current_mode) {
state->current_mode = target_mode;
}
state->hysteresis_counter = 0; /* Reset for next change */
}
} else {
/* Target changed, reset hysteresis */
state->pending_mode = target_mode;
state->hysteresis_counter = 1;
}
}
/* ============================================================================
* L8 Mode Application (Set L2/L3/L5/L6 Bits)
* ============================================================================
*/
/**
* @brief Apply the current L8 mode to a runtime configuration struct.
*
* Extracts the four loop-enable bits (L2/L3/L5/L6) from
* @c state->current_mode and writes them into @c config. Used by the
* legacy (non-table) L8 path when the adaptive UCB table is not present.
*
* @param state L8 state containing the committed current mode
* @param config Runtime configuration to update
*/
void ssm_apply_mode(const ssm_l8_state_t *state, ssm_config_t *config)
{
if (!state || !config) return;
/* Extract bits from mode (L2 L3 L5 L6) */
int mode_val = (int)state->current_mode;
config->L2_rolling_window = (mode_val >> 3) & 1; /* Bit 3 */
config->L3_linear_decay = (mode_val >> 2) & 1; /* Bit 2 */
config->L5_window_inference = (mode_val >> 1) & 1; /* Bit 1 */
config->L6_decay_inference = (mode_val >> 0) & 1; /* Bit 0 */
}
/* ============================================================================
* L8 Utility Functions
* ============================================================================
*/
/**
* @brief Return a human-readable name string for the given L8 mode.
*
* Returns a static string such as @c "C4_TEMPORAL" or @c "C15_FULL_ADAPTIVE".
* Modes marked ✅ TOP 5% are the configurations favoured by the DoE study.
* Returns @c "UNKNOWN" for out-of-range values.
*
* @param mode L8 mode enumeration value
* @return Pointer to a static null-terminated string (never NULL)
*/
const char* ssm_l8_mode_name(ssm_l8_mode_t mode)
{
switch (mode) {
case SSM_MODE_C0: return "C0_MINIMAL";
case SSM_MODE_C1: return "C1_DECAY_INF";
case SSM_MODE_C2: return "C2_WINDOW_INF";
case SSM_MODE_C3: return "C3_VOLATILE";
case SSM_MODE_C4: return "C4_TEMPORAL"; /* ✅ TOP 5% */
case SSM_MODE_C5: return "C5_TEMPORAL_DECAY_INF";
case SSM_MODE_C6: return "C6_TEMPORAL_WINDOW_INF";
case SSM_MODE_C7: return "C7_FULL_INFERENCE"; /* ✅ TOP 5% */
case SSM_MODE_C8: return "C8_DIVERSE";
case SSM_MODE_C9: return "C9_DIVERSE_DECAY_INF"; /* ✅ TOP 5% */
case SSM_MODE_C10: return "C10_DIVERSE_WINDOW_INF";
case SSM_MODE_C11: return "C11_DIVERSE_INFERENCE"; /* ✅ TOP 5% */
case SSM_MODE_C12: return "C12_DIVERSE_TEMPORAL"; /* ✅ TOP 5% */
case SSM_MODE_C13: return "C13_COMPLEX";
case SSM_MODE_C14: return "C14_FULL_ADAPTIVE_NO_DECAY_INF";
case SSM_MODE_C15: return "C15_FULL_ADAPTIVE";
default: return "UNKNOWN";
}
}
/* ============================================================================
* Adaptive Table: DoE Prior Seeding
* ============================================================================
*
* Maps the DoE top-5% 4-bit modes (L2/L3/L5/L6) to the 7-bit space
* (L1=0, L4=0, L7=1 held fixed for the high-score variants).
*
* Bit layout: b6=L1, b5=L2, b4=L3, b3=L4, b2=L5, b1=L6, b0=L7
*
* Top-5% modes (4-bit → 7-bit with L1=0,L4=0,L7=1):
* C4 (L3 only): 0100 → 0 0 1 0 0 0 1 = 0x11 = 17
* C7 (L3+L5+L6): 0111 → 0 0 1 0 1 1 1 = 0x17 = 23
* C9 (L2+L6): 1001 → 0 1 0 0 0 1 1 = 0x23 = 35
* C11 (L2+L5+L6): 1011 → 0 1 0 0 1 1 1 = 0x27 = 39
* C12 (L2+L3): 1100 → 0 1 1 0 0 0 1 = 0x31 = 49
*/
/**
* @brief Seed the adaptive UCB config table with DoE prior scores.
*
* Computes benefit scores derived from the DoE top-5% analysis for all
* @c cd_tuning_word().num_configs (128) configs and hands them to
* @c cd_config_table_seed(). The five top-5% configs (C4/C7/C9/C11/C12 in
* 4-bit space → indices 17/23/35/39/49 in 7-bit space) receive 80% of
* @c cd_tuning_word().score_max; configs involving L1 or L4 (known expensive
* loops) receive 5–10%; all others receive 40%. Sets the starting config
* to index 17 (C4-equivalent: L3+L7 only).
*
* @param table Pointer to the CDConfigTable to seed (already initialised
* via cd_config_table_init())
*/
static void ssm_l8_seed_from_doe(CDConfigTable *table)
{
/* Top-5% config indices in 7-bit space */
static const uint8_t top5[] = { 17u, 23u, 35u, 39u, 49u };
CDTuning tuning = cd_tuning_word();
uint32_t initial_scores[128];
uint32_t score_max = tuning.score_max;
uint32_t c, i;
for (c = 0u; c < tuning.num_configs; c++) {
uint8_t bits = (uint8_t)c;
int has_l1 = (bits & SSM_CFG_L1) != 0;
int has_l4 = (bits & SSM_CFG_L4) != 0;
int is_top5 = 0;
uint32_t score;
for (i = 0u; i < 5u; i++) {
if (bits == top5[i]) { is_top5 = 1; break; }
}
if (is_top5) score = (score_max * 80u) / 100u;
else if (has_l1 && has_l4) score = (score_max * 5u) / 100u;
else if (has_l1 || has_l4) score = (score_max * 10u) / 100u;
else score = (score_max * 40u) / 100u;
initial_scores[c] = score;
}
/* Start on C4-equivalent (config index 17: L3+L7 only) */
cd_config_table_seed(table, &tuning, initial_scores, 17u);
}
/* ============================================================================
* Adaptive Table: Per-Tick Reward + UCB Selection (static)
* ============================================================================ */
/**
* @brief Score the current config from this tick's outcome and UCB-select
* this tick's config.
*
* Computes a joint convergence signal from this tick's ANOVA outcome and
* the relative delta between this tick's and the previous tick's (window,
* locality) pair. Updates the regime-specific benefit score for the current
* config using exponential decay plus a signed delta -- the decay is what
* provides smoothing over time; there's no separate multi-tick batching on
* top of it (VM-FLEET-ATTRACTOR-DESIGN-20260705.md rev r: one clock, the
* heartbeat tick -- a tick is a tick). Then runs
* UCB1 over all 128 configs for the current regime, selecting the one with
* the highest upper confidence bound as this tick's config.
*
* @param table Adaptive config table
* @param config Runtime config to update with the newly selected bits
* @param metrics This tick's metrics snapshot (for the ANOVA signal)
* @param current_window Current rolling window width, this tick
* @param locality_q16 Current locality signal from cd_classify_ids(), this tick
*/
static void ssm_l8_tick_score_and_select(CDConfigTable *table, ssm_config_t *config,
const ssm_l8_metrics_t *metrics,
uint32_t current_window, uint32_t locality_q16)
{
CDTuning tuning = cd_tuning_word();
uint8_t active_bits = table->entries[table->current_config].config_bits;
int use_joint_convergence = ((active_bits & SSM_CFG_L5) || (active_bits & SSM_CFG_L6)) ? 1 : 0;
/* --- ANOVA stability: this tick's own outcome, not an accumulated
* fraction. Neutral (32768) when inference didn't run this tick --
* no signal either way, not "unstable." */
uint32_t anova_stability = metrics->inference_ran_this_tick
? (metrics->inference_early_exited ? 65536u : 0u)
: 32768u;
uint8_t bits = cd_config_table_tick(table, &tuning, table->current_regime,
anova_stability, use_joint_convergence,
current_window, locality_q16);
/* Apply new config bits to ssm_config_t -- all 7, not just the 4
* the legacy 16-mode selector could express. */
if (config != NULL) {
config->L1_heat_tracking = (bits & SSM_CFG_L1) ? 1 : 0;
config->L2_rolling_window = (bits & SSM_CFG_L2) ? 1 : 0;
config->L3_linear_decay = (bits & SSM_CFG_L3) ? 1 : 0;
config->L4_pipelining = (bits & SSM_CFG_L4) ? 1 : 0;
config->L5_window_inference = (bits & SSM_CFG_L5) ? 1 : 0;
config->L6_decay_inference = (bits & SSM_CFG_L6) ? 1 : 0;
config->L7_adaptive_heartrate = (bits & SSM_CFG_L7) ? 1 : 0;
}
}
/* ============================================================================
* Adaptive Table: Public API
* ============================================================================
*/
/**
* @brief Allocate and initialise the adaptive UCB config table.
*
* Mallocs and initialises a @c CDConfigTable sized by @c cd_tuning_word(),
* seeds it with @c ssm_l8_seed_from_doe(), and attaches it to
* @c state->table. If either allocation fails, @c state->table is set to
* NULL and the system falls back to legacy mode (@c ssm_apply_mode()).
*
* @param state L8 state that will own the table
*/
void ssm_l8_init_table(ssm_l8_state_t *state)
{
CDConfigTable *table;
CDTuning tuning;
if (!state) return;
table = (CDConfigTable *)malloc(sizeof(CDConfigTable));
if (!table) {
state->table = NULL; /* Fall back to legacy mode */
return;
}
tuning = cd_tuning_word();
if (cd_config_table_init(table, &tuning) != 0) {
free(table);
state->table = NULL; /* Fall back to legacy mode */
return;
}
ssm_l8_seed_from_doe(table);
state->table = table;
}
/**
* @brief Free the adaptive UCB config table owned by @c state.
*
* Safe to call with @c state->table == NULL. Sets @c state->table to NULL
* after freeing so the state falls back to legacy mode.
*
* @param state L8 state whose table is freed
*/
void ssm_l8_free_table(ssm_l8_state_t *state)
{
if (!state || !state->table) return;
cd_config_table_free(state->table);
free(state->table);
state->table = NULL;
}
/**
* @brief Tick the adaptive UCB table: classify, score, and reselect.
*
* Classifies the current tick into one of 8 regimes (entropy x CV x
* locality) and stores it unconditionally, then scores the current config
* from this tick's outcome and UCB-reselects, every single call -- no
* batching, no derived counter of any kind (VM-FLEET-ATTRACTOR-DESIGN-
* 20260705.md rev r: one clock, the heartbeat tick, applied uniformly).
* The locality component of both the regime and the joint-convergence
* reward comes from cd_classify_ids() over recent_word_ids -- purely
* execution-count-derived, no wall-clock input (rev s; see header comment
* on this function's declaration for why that matters). Also mirrors the
* winning L2/L3/L5/L6 bits back into @c state->current_mode for
* diagnostic display. No-op if @c state->table is NULL.
*
* @param state L8 state with attached adaptive table
* @param metrics Current runtime metrics snapshot
* @param config Runtime config updated this tick
* @param current_window Current rolling window width
* @param recent_word_ids Recent word-execution-ID history, oldest first
* @param recent_word_ids_count Number of valid entries in recent_word_ids
*/
void ssm_l8_update_table(ssm_l8_state_t *state, const ssm_l8_metrics_t *metrics,
ssm_config_t *config,
uint32_t current_window,
const uint32_t *recent_word_ids, uint32_t recent_word_ids_count)
{
CDConfigTable *table;
CDTuning tuning = cd_tuning_word();
CDRegimeMetrics cd;
uint8_t regime;
if (!state || !state->table || !metrics) return;
table = state->table;
cd = cd_classify_ids(recent_word_ids, recent_word_ids_count,
tuning.locality_lookback);
/* Current regime (same 3-bit shape as legacy L8), stored every tick,
* unconditionally. */
regime = (uint8_t)(
((metrics->entropy >= SSM_ENTROPY_HIGH_THRESHOLD) ? 4u : 0u) |
((metrics->cv >= SSM_CV_HIGH_THRESHOLD) ? 2u : 0u) |
((cd.locality_q16 >= tuning.locality_high_threshold_q16) ? 1u : 0u)
);
table->current_regime = regime;
ssm_l8_tick_score_and_select(table, config, metrics, current_window, cd.locality_q16);
/* Mirror L2/L3/L5/L6 bits into the legacy mode field for diagnostics */
{
uint8_t bits = table->entries[table->current_config].config_bits;
state->current_mode = (ssm_l8_mode_t)(
(((bits & SSM_CFG_L2) ? 1u : 0u) << 3) |
(((bits & SSM_CFG_L3) ? 1u : 0u) << 2) |
(((bits & SSM_CFG_L5) ? 1u : 0u) << 1) |
(((bits & SSM_CFG_L6) ? 1u : 0u) << 0)
);
}
}
/**
* @brief Apply the UCB-selected config bits to a runtime configuration struct.
*
* Reads the current winning config entry from the adaptive table and writes
* all 7 of its bits into @c config. Use this instead of @c ssm_apply_mode()
* when the adaptive table is present (@c state->table != NULL).
*
* @param state L8 state with an attached, initialised adaptive table
* @param config Runtime configuration to update
*/
void ssm_apply_mode_from_table(const ssm_l8_state_t *state, ssm_config_t *config)
{
const CDConfigTable *table;
uint8_t bits;
if (!state || !state->table || !config) return;
table = state->table;
bits = table->entries[table->current_config].config_bits;
config->L1_heat_tracking = (bits & SSM_CFG_L1) ? 1 : 0;
config->L2_rolling_window = (bits & SSM_CFG_L2) ? 1 : 0;
config->L3_linear_decay = (bits & SSM_CFG_L3) ? 1 : 0;
config->L4_pipelining = (bits & SSM_CFG_L4) ? 1 : 0;
config->L5_window_inference = (bits & SSM_CFG_L5) ? 1 : 0;
config->L6_decay_inference = (bits & SSM_CFG_L6) ? 1 : 0;
config->L7_adaptive_heartrate = (bits & SSM_CFG_L7) ? 1 : 0;
}
/**
* @brief Force the adaptive table onto an externally-chosen config.
*
* Sets @c current_config directly (as if the bandit's own UCB selection had
* picked it) and applies its bits immediately. Since scoring and UCB
* reselection now run on every heartbeat tick (rev r: one clock, no
* batching of any kind), this is a one-tick nudge, not a hold: the
* forced config earns exactly one tick's worth of reward signal into its
* own regime_score, then the very next tick's ssm_l8_update_table() call
* scores it and reselects on its own, same as any other tick. Calling
* this repeatedly (e.g. once per DoE draw, faster than the VM's own
* tick cadence) keeps a config in effect in practice, not because it's
* pinned -- because it's what's currently forced, most recently.
*
* @param state L8 state with an attached, initialised adaptive table
* @param config Runtime configuration to update immediately
* @param config_idx Desired config, masked to the 128-entry (7-bit) space
*/
void ssm_l8_force_config(ssm_l8_state_t *state, ssm_config_t *config, uint8_t config_idx)
{
if (!state || !state->table || !config) return;
cd_config_table_force(state->table, config_idx & 0x7Fu);
ssm_apply_mode_from_table(state, config);
}
v3/src/stack_management.c
+177
View File
@@ -0,0 +1,177 @@
/*
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.
*/
/**
* @file stack_management.c
* @brief Implementation of stack operations for the Forth virtual machine
*
* This module provides the core stack manipulation functions for both the data stack
* and return stack of the Forth virtual machine. It includes optimized assembly
* implementations for x86_64 and ARM64 architectures when available.
*/
#include "vm.h"
#include "log.h"
#include "profiler.h"
#if defined(USE_ASM_OPT) && USE_ASM_OPT
# if defined(ARCH_X86_64)
# include "vm_asm_opt.h"
# elif defined(ARCH_ARM64) || defined(__aarch64__) || defined(__arm64__)
# include "vm_asm_opt_arm64.h"
# elif defined(ARCH_RISCV64) || (defined(__riscv) && (__riscv_xlen == 64))
# include "vm_asm_opt_riscv64.h"
# endif
#endif
/**
* @brief Push a value onto the data stack
*
* @param vm Pointer to the VM structure
* @param value Value to push onto the stack
*
* @note Performs bounds checking to prevent stack overflow
* @note Uses assembly optimization if available for x86_64 or ARM64
*/
void vm_push(VM *vm, cell_t value) {
PROFILE_INC_STACK_OP();
#if defined(USE_ASM_OPT) && USE_ASM_OPT && (defined(ARCH_X86_64) || defined(ARCH_ARM64) || defined(ARCH_RISCV64))
/* Use optimized assembly version for x86_64 or ARM64 */
vm_push_asm(vm, value);
#ifndef NDEBUG
if (!vm->error) {
log_message(LOG_DEBUG, "PUSH: %ld (dsp=%d)", value, vm->dsp);
}
#endif
#else
/* Standard C implementation */
if (vm->dsp >= STACK_SIZE - 1) {
log_message(LOG_ERROR, "Stack overflow");
vm->error = 1;
return;
}
vm->data_stack[++vm->dsp] = value;
log_message(LOG_DEBUG, "PUSH: %ld (dsp=%d)", value, vm->dsp);
#endif
}
/**
* @brief Pop a value from the data stack
*
* @param vm Pointer to the VM structure
* @return The popped value
*
* @note Returns 0 and sets error flag if stack underflow occurs
* @note Uses assembly optimization if available for x86_64 or ARM64
*/
cell_t vm_pop(VM *vm) {
PROFILE_INC_STACK_OP();
#if defined(USE_ASM_OPT) && USE_ASM_OPT && (defined(ARCH_X86_64) || defined(ARCH_ARM64) || defined(ARCH_RISCV64))
/* Use optimized assembly version for x86_64 */
cell_t value = vm_pop_asm(vm);
#ifndef NDEBUG
if (!vm->error) {
log_message(LOG_DEBUG, "POP: %ld (dsp=%d)", value, vm->dsp);
}
#endif
return value;
#else
/* Standard C implementation */
if (vm->dsp < 0) {
log_message(LOG_ERROR, "Stack underflow (dsp=%d)", vm->dsp);
vm->error = 1;
return 0;
}
cell_t value = vm->data_stack[vm->dsp--];
log_message(LOG_DEBUG, "POP: %ld (dsp=%d)", value, vm->dsp);
return value;
#endif
}
/**
* @brief Push a value onto the return stack
*
* @param vm Pointer to the VM structure
* @param value Value to push onto the return stack
*
* @note Sets error flag if stack overflow occurs
* @note Uses assembly optimization if available for x86_64 or ARM64
*/
void vm_rpush(VM *vm, cell_t value) {
#if defined(USE_ASM_OPT) && USE_ASM_OPT && (defined(ARCH_X86_64) || defined(ARCH_ARM64) || defined(ARCH_RISCV64))
/* Use optimized assembly version for x86_64 */
vm_rpush_asm(vm, value);
#else
/* Standard C implementation */
if (vm->rsp >= STACK_SIZE - 1) {
vm->error = 1; /* Return stack overflow */
return;
}
vm->return_stack[++vm->rsp] = value;
#endif
}
/**
* @brief Pop a value from the return stack
*
* @param vm Pointer to the VM structure
* @return The popped value
*
* @note Returns 0 and sets error flag if stack underflow occurs
* @note Uses assembly optimization if available for x86_64 or ARM64
*/
cell_t vm_rpop(VM *vm) {
#if defined(USE_ASM_OPT) && USE_ASM_OPT && (defined(ARCH_X86_64) || defined(ARCH_ARM64) || defined(ARCH_RISCV64))
/* Use optimized assembly version for x86_64 */
return vm_rpop_asm(vm);
#else
/* Standard C implementation */
if (vm->rsp < 0) {
vm->error = 1; /* Return stack underflow */
return 0;
}
cell_t value = vm->return_stack[vm->rsp--];
return value;
#endif
}
v3/src/test_runner/README.md
+17
View File
@@ -0,0 +1,17 @@
# src/test_runner/
Test harness for the hosted VM's test suite, run via
`./starforth --run-tests`. Organized in POST (Power-On Self Test) order:
unit tests → dictionary/word-category tests → integration/stress/
adversarial tests.
- `test_runner.c` — test harness orchestration (loads and runs all
modules in POST order).
- `test_common.c` — shared test utilities.
- `test_contracts.c` — contract-based testing infrastructure (pre/post
condition assertions around word execution).
Subdirectories:
- `include/` — public headers for this harness.
- `modules/` — per-category test files; see
`src/test_runner/modules/README.md`.
v3/src/test_runner/include/README.md
+8
View File
@@ -0,0 +1,8 @@
# src/test_runner/include/
Public headers for the test harness.
- `test_runner.h` — harness orchestration interface.
- `test_common.h` — shared test utility declarations.
- `test_contracts.h` — contract-based testing (pre/post-condition
assertion) interface.
v3/src/test_runner/include/test_common.h
+214
View File
@@ -0,0 +1,214 @@
/*
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.
*/
/**
* @file test_common.h
* @brief Common test utilities and structures for StarForth test runner
* @details This file contains test configuration, structures, and utility functions
* used throughout the StarForth test framework.
*/
#ifndef TEST_COMMON_H
#define TEST_COMMON_H
#include "../../../include/vm.h"
#include "../../../include/log.h"
#include "test_contracts.h"
/** @name Test Configuration
* @{
*/
/** Maximum length of test output buffer */
#define MAX_TEST_OUTPUT 1024
/** Maximum length of test input buffer */
#define MAX_TEST_INPUT 256
/** Maximum number of test cases per word */
#define MAX_TESTS_PER_WORD 20
/** @} */
/* fail fast */
extern int fail_fast;
/** @brief Types of test cases */
typedef enum {
TEST_NORMAL = 0, /**< Standard test case */
TEST_EDGE_CASE = 1, /**< Edge case test */
TEST_ERROR_CASE = 2 /**< Error condition test */
} TestType;
/** @brief Structure representing a single test case */
typedef struct {
const char *name; /**< Name of the test case */
const char *input; /**< Input Forth code */
const char *expected; /**< Expected output */
TestType type; /**< Type of test case */
int should_error; /**< Whether test should produce an error */
int implemented; /**< Whether the functionality is implemented */
WordContract contract; /**< Per-test contract override; zero = inherit from suite/module */
} TestCase;
/** @brief Collection of test cases for a single Forth word */
typedef struct {
const char *word_name; /**< Name of the Forth word being tested */
TestCase tests[MAX_TESTS_PER_WORD]; /**< Array of test cases */
int test_count; /**< Number of tests in the suite */
WordContract suite_contract; /**< Suite-level contract; zero = inherit from module */
} WordTestSuite;
/** @name Core Test Execution Functions
* @{
*/
/*
* @brief Executes a single test case
* @param vm Pointer to the VM instance
* @param word_name Name of the word being tested
* @param test Test case to execute
* @return Test execution result
*/
TestResult run_single_test(VM *vm, const char *word_name, const TestCase *test);
/*
* @brief Runs all tests in a test suite
* @param vm Pointer to the VM instance
* @param suite Test suite to execute
*/
void run_test_suite(VM *vm, const WordTestSuite *suite);
/**
* @brief Runs all tests in a suite with an inherited module-level contract.
*
* Contract resolution order (first non-NONE wins):
* test->contract > suite->suite_contract > module_contract
*
* When CONTRACTS_ENABLED=1, each passing TEST_NORMAL test is re-run under
* physics perturbation to witness A4' (word_physics_transparent).
*
* @param vm Pointer to the VM instance
* @param suite Test suite to execute
* @param module_contract Default contract for tests that don't specify one
*/
void run_test_suite_m(VM *vm, const WordTestSuite *suite, WordContract module_contract);
/*
* @brief Prints test results_run_01_2025_12_08 summary for a module
* @param module_name Name of the module
* @param pass Number of passed tests
* @param fail Number of failed tests
* @param skip Number of skipped tests
* @param error Number of errors
*/
void print_module_summary(const char *module_name, int pass, int fail, int skip, int error);
/** @} */
/** @name Test Assertion Functions
* @{
*/
/*
* @brief Verifies the VM stack depth
* @param vm Pointer to the VM instance
* @param expected_depth Expected stack depth
* @return 1 if assertion passes, 0 otherwise
*/
int assert_stack_depth(VM *vm, int expected_depth);
/*
* @brief Verifies the value at the top of the stack
* @param vm Pointer to the VM instance
* @param expected_value Expected value
* @return 1 if assertion passes, 0 otherwise
*/
int assert_stack_top(VM *vm, int expected_value);
/*
* @brief Verifies VM error state
* @param vm Pointer to the VM instance
* @param should_have_error Expected error state
* @return 1 if assertion passes, 0 otherwise
*/
int assert_vm_error(VM *vm, int should_have_error);
/** @} */
/** @name VM State Management Functions
* @{
*/
/*
* @brief Saves current VM state
* @param vm Pointer to the VM instance
* @param dsp Pointer to store data stack pointer
* @param rsp Pointer to store return stack pointer
* @param error Pointer to store error state
* @param mode Pointer to store VM mode
*/
void save_vm_state(VM *vm, int *dsp, int *rsp, int *error, vm_mode_t *mode);
/*
* @brief Restores VM state from saved values
* @param vm Pointer to the VM instance
* @param dsp Data stack pointer to restore
* @param rsp Return stack pointer to restore
* @param error Error state to restore
* @param mode VM mode to restore
*/
void restore_vm_state(VM *vm, int dsp, int rsp, int error, vm_mode_t mode);
/*
* @brief Saves dictionary state before test execution
* @param vm Pointer to VM instance
* @param latest Pointer to store latest dictionary entry
* @param here Pointer to store HERE pointer
*/
void save_dict_state(VM * vm, DictEntry * *latest, size_t * here);
/*
* @brief Restores dictionary state after test execution
* @param vm Pointer to VM instance
* @param latest Latest dictionary entry to restore
* @param here HERE pointer to restore
* @details Removes all words added during test by restoring dictionary pointers
*/
void restore_dict_state(VM *vm, DictEntry *latest, size_t here);
/** @} */
#endif /* TEST_COMMON_H */
v3/src/test_runner/include/test_contracts.h
+121
View File
@@ -0,0 +1,121 @@
/*
StarForth — Steady-State Virtual Machine Runtime
Copyright (c) 2023–2025 Robert A. James
Licensed under the Starship License 1.0 (SL-1.0)
*/
#ifndef TEST_CONTRACTS_H
#define TEST_CONTRACTS_H
#include "vm.h" /* resolved via -Iinclude */
#include <stdint.h>
#include <stddef.h>
/* ============================================================================
* Word Contract System — Runtime witnesses for Isabelle/HOL axioms
*
* Two axioms require runtime verification:
* A1 heartbeat_exec_neutral — vm_tick() must not write exec-equiv fields
* A4' word_physics_transparent — word results must be independent of physics state
*
* Contracts attach at three levels; resolution order (first non-NONE wins):
* individual TestCase > WordTestSuite.suite_contract > module_contract arg
*
* Contract checks run unconditionally as part of POST.
* ============================================================================ */
typedef uint32_t contract_flags_t;
#define CONTRACT_NONE 0u
/* A4': re-run word with perturbed physics; assert identical exec result */
#define CONTRACT_PHYSICS_TRANSPARENT (1u << 0)
/* A1: call vm_tick() and assert exec-equiv fields are unchanged */
#define CONTRACT_HEARTBEAT_SAFE (1u << 1)
/* Number of physics perturbation rounds per test case (0 = use default) */
#define CONTRACT_DEFAULT_FUZZ_ROUNDS 4
typedef struct {
contract_flags_t flags;
int fuzz_rounds; /* 0 = use CONTRACT_DEFAULT_FUZZ_ROUNDS */
} WordContract;
/* Exec-domain snapshot — exactly the four fields in exec_equiv */
typedef struct {
cell_t stack[STACK_SIZE];
int dsp;
int rsp;
int error;
} ExecResult;
/* Physics field snapshot for save/restore around A4' checks */
typedef struct {
uint64_t decay_slope_q48;
uint32_t eff_window_size;
uint64_t tick_target_ns;
cell_t heat_25th;
cell_t heat_50th;
cell_t heat_75th;
uint64_t prefetch_attempts;
uint64_t total_executions;
} PhysicsSnapshot;
/* Global counter incremented on each contract violation (CONTRACTS_ENABLED only) */
extern int global_contract_violations;
/*
* Accessor functions for global_contract_violations.
* Use these from other TUs — direct extern access generates GOTPCRELX which
* the PE linker does not relax, causing double-dereference bugs in -fPIC PE builds.
*/
int contract_get_violation_count(void);
void contract_reset_violation_count(void);
/*
* capture_exec_result — snapshot the four exec-equiv fields from vm into r.
*/
void capture_exec_result(VM *vm, ExecResult *r);
/*
* exec_results_equal — 1 if a and b agree on dsp, rsp, error, and live stack.
*/
int exec_results_equal(const ExecResult *a, const ExecResult *b);
/*
* save_physics / restore_physics — snapshot and restore key physics scalars.
*/
void save_physics(VM *vm, PhysicsSnapshot *s);
void restore_physics(VM *vm, const PhysicsSnapshot *s);
/*
* perturb_physics — replace key physics scalars with fresh random values.
* round is used to vary the RNG seed across multiple rounds.
*/
void perturb_physics(VM *vm, int round);
/*
* check_physics_transparent — A4' contract check for a single test case.
*
* Runs input with the current physics state (baseline), then runs it again
* fuzz_rounds times with physics perturbed, asserting identical ExecResult
* each time. Returns 1 if all rounds match, 0 on first violation (which is
* also logged as an error). Skips error-expected and unimplemented tests.
*
* NOTE: input must not define dictionary words; the dict is not snapshotted
* inside this function. Callers that cover defining-words tests should
* save/restore dict state around this call.
*/
int check_physics_transparent(VM *vm, const char *word_name,
const char *input,
int should_error, int implemented,
int fuzz_rounds);
/*
* assert_heartbeat_safe — A1 contract check.
*
* Snapshots exec-equiv fields, calls vm_tick(), then asserts all four fields
* are unchanged. Returns 1 if the assertion holds, 0 on violation.
*/
int assert_heartbeat_safe(VM *vm);
#endif /* TEST_CONTRACTS_H */
v3/src/test_runner/include/test_runner.h
+181
View File
@@ -0,0 +1,181 @@
/*
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.
*/
#ifndef TEST_RUNNER_H
#define TEST_RUNNER_H
#include "../../../include/vm.h"
#include <stdint.h>
/**
* @brief Structure holding test execution statistics
*/
typedef struct {
int total_tests; /**< Total number of tests executed */
int total_pass; /**< Number of passed tests */
int total_fail; /**< Number of failed tests */
int total_skip; /**< Number of skipped tests */
int total_error; /**< Number of tests that resulted in errors */
} TestStats;
/**
* @brief Structure representing a test module
*/
typedef struct {
const char *module_name; /**< Name of the test module */
void *reserved; /**< Reserved for future use */
int reserved_int; /**< Reserved integer value */
void (*run_module_tests)(VM *vm); /**< Function pointer to run module tests */
} TestModule;
/* Global test statistics - extern declaration */
extern TestStats global_test_stats;
/*
* Same-TU accumulator — use instead of direct struct access from other TUs.
* Direct extern struct access generates R_X86_64_REX_GOTPCRELX which the
* PE linker does not relax, causing double-dereference in -fPIC PE builds.
*/
void test_stats_accumulate(int tests, int pass, int fail, int skip, int error);
/*
* @brief Run tests for stack manipulation words
* @param vm Pointer to the VM instance
*/
void run_stack_words_tests(VM * vm);
void run_return_stack_words_tests(VM * vm);
void run_memory_words_tests(VM * vm);
void run_arithmetic_words_tests(VM * vm);
void run_logical_words_tests(VM * vm);
void run_mixed_arithmetic_words_tests(VM * vm);
void run_double_words_tests(VM * vm);
void run_dictionary_words_tests(VM * vm);
void run_io_words_tests(VM * vm);
void run_format_words_tests(VM * vm);
void run_string_words_tests(VM * vm);
void run_dictionary_manipulation_words_tests(VM * vm);
void run_vocabulary_words_tests(VM * vm);
void run_block_words_tests(VM * vm);
void run_system_words_tests(VM * vm);
void run_defining_words_tests(VM * vm);
void run_control_words_tests(VM * vm);
void run_starforth_words_tests(VM * vm);
void run_acl_words_tests(VM * vm);
/*
* @brief Run tests for Q48.16 fixed-point words (Module 25)
* @param vm Pointer to the VM instance
*/
void run_q48_words_tests(VM * vm);
/*
* @brief Run tests for the proof-covered subset of inference-engine words (Module 26)
* @param vm Pointer to the VM instance
*/
void run_inference_words_tests(VM * vm);
/*
* @brief Run tests for the proof-covered subset of physics-freeze words (Module 27)
* @param vm Pointer to the VM instance
*/
void run_physics_freeze_words_tests(VM * vm);
/*
* @brief Run tests for Mama FORTH vocabulary (capsule system M7.1)
* @param vm Pointer to the VM instance
*
* In hosted builds, all tests are skipped (Mama words are kernel-only).
* In kernel builds, tests validate capsule enumeration and VM birth.
*/
void run_mama_forth_words_tests(VM * vm);
/*
* @brief Enable benchmark mode for performance testing
* @param iterations Number of iterations for benchmark tests
*/
void enable_benchmark_mode(int iterations);
/*
* @brief Execute stress tests
* @param vm Pointer to the VM instance
*/
void run_stress_tests(VM * vm);
/*
* @brief Execute integration tests
* @param vm Pointer to the VM instance
*/
void run_integration_tests(VM * vm);
/*
* @brief Run all available tests
* @param vm Pointer to the VM instance
*/
void run_all_tests(VM * vm);
/*
* @brief Run tests for a specific module
* @param vm Pointer to the VM instance
* @param module_name Name of the module to test
*/
void run_module_tests(VM *vm, const char *module_name);
/*
* @brief Run tests for a specific word
* @param vm Pointer to the VM instance
* @param word_name Name of the word to test
*/
void run_word_tests(VM *vm, const char *word_name);
/**
* @brief Run ultra-comprehensive break-me diagnostic suite
* @param vm Pointer to the VM instance
*
* Executes the most exhaustive test battery ever designed for StarForth,
* generates a detailed markdown report in docs/BREAK_ME_REPORT.md,
* and includes a surprise easter egg at the end.
*/
void run_break_me_tests(VM * vm);
#endif /* TEST_RUNNER_H */
v3/src/test_runner/modules/README.md
+26
View File
@@ -0,0 +1,26 @@
# src/test_runner/modules/
Per-category test files, one per FORTH-79 word category plus
integration/stress/adversarial suites, run in this order by
`test_runner.c` (POST order).
**Word-category tests** (validate each `src/word_source/*.c` file):
`arithmetic_words_test.c`, `mixed_arithmetic_words_test.c`,
`stack_words_test.c`, `control_words_test.c`, `defining_words_tests.c`,
`memory_words_test.c`, `return_stack_words_test.c`, `double_words_test.c`,
`logical_words_test.c`, `io_words_test.c`, `string_words_test.c`,
`block_words_test.c`, `format_words_test.c`, `system_words_test.c`,
`dictionary_words_test.c`, `dictionary_manipulation_words_test.c`,
`vocabulary_words_test.c`, `starforth_words_test.c`,
`mama_forth_words_test.c`, `acl_words_test.c`.
**Cross-cutting tests**:
- `integration_tests.c` — multi-word interaction tests.
- `stress_tests.c` — load/volume tests.
- `break_me_tests.c` — adversarial/fuzzing tests.
Note: not every `src/word_source/*.c` file has a dedicated test module
here (e.g. `defer_words.c`, `log_words.c`, `inference_words.c`,
`lifecycle_words_hosted.c`, `editor_words.c` are exercised indirectly via
integration tests or the `tools/hermes_*.sh` smoke tests rather than a
standalone `*_test.c` module).
v3/src/test_runner/modules/acl_words_test.c
+628
View File
@@ -0,0 +1,628 @@
/*
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.
*/
/*
* acl_words_test.c — POST tests for the word-level ACL system (Module 24)
*
* Tests directly manipulate DictEntry ACL fields in C and then verify
* behaviour through the interpreter or via direct field inspection.
* This avoids depending on ACL.4th being loaded during POST.
*/
#include "../include/test_runner.h"
#include "../include/test_common.h"
#include "../../../include/vm.h"
#include "../../word_source/include/acl_words.h"
#include <stdio.h>
/* ------------------------------------------------------------------ */
static int tests_passed = 0;
static int tests_failed = 0;
#define ACL_ASSERT(cond, msg) \
do { \
if (cond) { \
tests_passed++; \
log_message(LOG_DEBUG, " PASS: %s", msg); \
} else { \
tests_failed++; \
log_message(LOG_ERROR, " FAIL: %s", msg); \
} \
} while (0)
/* ------------------------------------------------------------------ */
/**
* @brief Test 1 — ACL-PIN is a one-way ratchet.
*
* Creates a temporary word and pins it via @c ACL-PIN. Verifies that
* subsequent calls to @c ACL-MODE!, @c ACL-TTL!, and @c ACL-ALLOW! are
* all no-ops while the word is pinned. The pin flag itself must remain 1.
*
* Expected assertions (4):
* - @c acl_pinned == 1 after ACL-PIN
* - @c acl_mode unchanged after ACL-MODE! on pinned entry
* - @c acl_ttl unchanged after ACL-TTL! on pinned entry
* - @c acl_allow unchanged after ACL-ALLOW! on pinned entry
*
* @param vm VM instance (shared state; caller restores after this function).
*/
static void test_acl_pin_immutable(VM *vm)
{
DictEntry *e = vm_create_word(vm, "__acl_pin_test__", 16, NULL);
if (!e) { tests_failed++; return; }
e->acl_mode = ACL_MODE_TTL;
e->acl_pinned = 0;
/* Pin it */
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-PIN");
vm->error = 0;
ACL_ASSERT(e->acl_pinned == 1, "ACL-PIN sets acl_pinned=1");
/* Attempt to change mode via ACL-MODE! (C primitive) — should be no-op when pinned */
vm_push(vm, (cell_t)ACL_MODE_STRICT);
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-MODE!");
vm->error = 0;
ACL_ASSERT(e->acl_mode == ACL_MODE_TTL, "ACL-STRICT is no-op when pinned");
/* Attempt to change TTL — should be ignored */
uint32_t old_ttl = e->acl_ttl;
vm_push(vm, (cell_t)9999);
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-TTL!");
vm->error = 0;
ACL_ASSERT(e->acl_ttl == old_ttl, "ACL-TTL! is no-op when pinned");
/* Attempt to change allow — should be ignored */
e->acl_allow = 1;
vm_push(vm, (cell_t)0);
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-ALLOW!");
vm->error = 0;
ACL_ASSERT(e->acl_allow == 1, "ACL-ALLOW! is no-op when pinned");
}
/**
* @brief Test 2 — ACL-INHERIT copies mode, clears pin, and resets TTL/allow.
*
* Constructs a source entry with STRICT mode, pinned, TTL=5000, allow=0,
* and a destination entry with a different mode and also pinned. Calls
* @c acl_inherit_entry() directly and checks the resulting destination
* state. Verifies the Isabelle/HOL lemma @c ACL_Inherit_Clears_Pin.
*
* Expected assertions (4):
* - @c dst->acl_mode == ACL_MODE_STRICT (mode copied from src)
* - @c dst->acl_pinned == 0 (pin cleared regardless of dst's original pin)
* - @c dst->acl_ttl == 0 (TTL reset to 0)
* - @c dst->acl_allow == 1 (allow reset to 1)
*
* @param vm VM instance (used for word creation; not modified beyond that).
*/
static void test_acl_inherit(VM *vm)
{
DictEntry *src = vm_create_word(vm, "__acl_src__", 11, NULL);
DictEntry *dst = vm_create_word(vm, "__acl_dst__", 11, NULL);
if (!src || !dst) { tests_failed++; return; }
src->acl_mode = ACL_MODE_STRICT;
src->acl_pinned = 1;
src->acl_ttl = 5000;
src->acl_allow = 0;
dst->acl_pinned = 1; /* even a pinned dst should be cleared */
dst->acl_mode = ACL_MODE_TTL;
acl_inherit_entry(src, dst);
ACL_ASSERT(dst->acl_mode == ACL_MODE_STRICT, "ACL-INHERIT copies acl_mode");
ACL_ASSERT(dst->acl_pinned == 0, "ACL-INHERIT clears acl_pinned");
ACL_ASSERT(dst->acl_ttl == 0, "ACL-INHERIT resets acl_ttl to 0");
ACL_ASSERT(dst->acl_allow == 1, "ACL-INHERIT resets acl_allow to 1");
}
/**
* @brief Test 3 — emergency_console flag bypasses a denied word.
*
* Defines a FORTH word that pushes 42, then sets its @c acl_allow to 0
* to simulate a policy denial. Executes the word with @c emergency_console=1
* and verifies that the word body ran (stack depth increased by 1).
*
* The @c emergency_console bypass is required by the bare-metal fault
* handler so that critical recovery words can always execute.
*
* Expected assertions (1):
* - @c vm->dsp == saved_dsp + 1 (word ran despite deny)
*
* @param vm VM instance.
*/
static void test_emergency_console_bypass(VM *vm)
{
/* Define a simple FORTH word that pushes a marker */
vm_interpret(vm, ": __acl_ec_test__ 42 ;");
vm->error = 0;
DictEntry *e = vm_find_word(vm, "__acl_ec_test__", 15);
if (!e) { tests_failed++; return; }
/* Deny it */
e->acl_allow = 0;
e->acl_ttl = 0;
e->acl_pinned = 0;
/* With emergency_console=1: should execute despite deny */
int saved_dsp = vm->dsp;
vm->emergency_console = 1;
vm_interpret(vm, "__acl_ec_test__");
vm->emergency_console = 0;
vm->error = 0;
ACL_ASSERT(vm->dsp == saved_dsp + 1, "emergency_console bypasses ACL deny");
if (vm->dsp > saved_dsp) vm->dsp--; /* pop the 42 */
/* Restore allow so subsequent tests don't trip over it */
e->acl_allow = 1;
}
/**
* @brief Test 4 — ACL denial aborts execution without running the word body.
*
* Defines a word that pushes a sentinel (99), then denies it with
* @c acl_allow=0 and @c acl_ttl=1 (hot-path decrement triggers the deny
* check without invoking @c acl_recheck()). Verifies that executing the
* word sets either @c vm->abort_requested, @c vm->error, or leaves the
* stack depth unchanged — and that the sentinel was never pushed.
*
* @c acl_ttl=1 is used rather than 0 to stay on the hot path (TTL
* decrements to 0 → check; avoids the fail-open cold-path recheck).
*
* Expected assertions (2):
* - Execution was aborted (abort_requested || error || stack unchanged)
* - Stack depth is unchanged (sentinel was not pushed)
*
* @param vm VM instance.
*/
static void test_acl_deny_aborts(VM *vm)
{
/* Define a word that pushes a sentinel value */
vm_interpret(vm, ": __acl_deny_test__ 99 ;");
vm->error = 0;
DictEntry *e = vm_find_word(vm, "__acl_deny_test__", 17);
if (!e) { tests_failed++; return; }
e->acl_allow = 0;
e->acl_ttl = 1; /* hot path: decrement then check; avoids fail-open recheck */
e->acl_pinned = 0;
int saved_dsp = vm->dsp;
vm->emergency_console = 0;
vm_interpret(vm, "__acl_deny_test__");
int was_aborted = (vm->abort_requested || vm->error || vm->dsp == saved_dsp);
vm->abort_requested = 0;
vm->error = 0;
ACL_ASSERT(was_aborted, "denied word triggers abort");
ACL_ASSERT(vm->dsp == saved_dsp, "denied word: stack unchanged");
e->acl_allow = 1;
}
/**
* @brief Test 5 — ACL TTL hot-path decrements without invoking recheck.
*
* Defines a word with @c acl_ttl=10 and @c acl_allow=1, then executes
* it three times via the outer interpreter. Each outer-interpreter
* execution decrements @c acl_ttl by 1, so the expected final value is 7.
*
* This confirms the hot-path optimisation: the interpreter only calls
* @c acl_recheck() when @c acl_ttl reaches 0, not on every invocation.
*
* Expected assertions (1):
* - @c e->acl_ttl == 7 after three executions (10 → 9 → 8 → 7)
*
* @param vm VM instance.
*/
static void test_acl_ttl_hot_path(VM *vm)
{
vm_interpret(vm, ": __acl_ttl_test__ 1 DROP ;");
vm->error = 0;
DictEntry *e = vm_find_word(vm, "__acl_ttl_test__", 16);
if (!e) { tests_failed++; return; }
e->acl_allow = 1;
e->acl_ttl = 10;
e->acl_pinned = 0;
e->acl_mode = ACL_MODE_TTL;
/* Execute the word 3 times via the outer interpreter */
vm->emergency_console = 0;
vm_interpret(vm, "__acl_ttl_test__");
vm->error = 0;
vm_interpret(vm, "__acl_ttl_test__");
vm->error = 0;
vm_interpret(vm, "__acl_ttl_test__");
vm->error = 0;
ACL_ASSERT(e->acl_ttl == 7, "TTL hot path: TTL decrements from 10 to 7 after 3 execs");
}
/**
* @brief Test 6 — STRICT mode keeps TTL at 0 after every recheck.
*
* In @c ACL_MODE_STRICT, @c ACL-RECHECK must reset @c acl_ttl to 0 after
* each allow decision so the recheck fires on every subsequent execution.
*
* If @c ACL.4th is not loaded, @c ACL-RECHECK is absent and @c acl_recheck()
* fails open (@c acl_ttl = @c ACL_TTL_OPEN). In that case the test is
* conditionally skipped (counted as a pass) since the ACL system is not
* yet active.
*
* Expected assertions (1, or skip counted as 1 pass):
* - @c e->acl_ttl == 0 after one execution in STRICT mode with ACL loaded.
*
* @param vm VM instance.
*/
static void test_acl_strict_mode(VM *vm)
{
vm_interpret(vm, ": __acl_strict_test__ DROP ;");
vm->error = 0;
DictEntry *e = vm_find_word(vm, "__acl_strict_test__", 19);
if (!e) { tests_failed++; return; }
e->acl_mode = ACL_MODE_STRICT;
e->acl_allow = 1;
e->acl_ttl = 0;
e->acl_pinned = 0;
/* ACL-RECHECK for STRICT mode must reset TTL to 0 after allowing */
vm_push(vm, (cell_t)(uintptr_t)e);
DictEntry *recheck = vm_find_word(vm, "ACL-RECHECK", 11);
if (recheck) {
/* ACL-RECHECK is not yet in the dict (ACL.4th not loaded) — skip FORTH call */
/* Test via acl_recheck() directly: in STRICT mode, TTL stays 0 */
/* We can't call acl_recheck() directly (static), but we can test
that the vm_interpret path triggers the recheck path correctly.
After execution with TTL=0 and allow=1, TTL should still be 0
in STRICT mode (recheck was called and set TTL=0 again). */
vm->dsp--; /* clean up the push above */
vm_interpret(vm, "0 __acl_strict_test__");
vm->error = 0;
ACL_ASSERT(e->acl_ttl == 0, "STRICT mode: TTL remains 0 after recheck");
} else {
/* ACL.4th not loaded yet — fallback sets TTL=OPEN; note but don't fail */
vm->dsp--;
log_message(LOG_INFO, " SKIP: STRICT mode test (ACL.4th not loaded)");
tests_passed++; /* conditional skip counts as pass in POST */
}
}
/**
* @brief Test 7 — Adaptive TTL scales with execution heat via ACL-TTL-COMPUTE.
*
* Sets @c execution_heat=2560 on a temporary entry and invokes
* @c ACL-TTL-COMPUTE if the word is present (i.e., @c ACL.4th is loaded).
* The expected formula is @c ttl = heat/4 + 256 = 640 + 256 = 896.
*
* If @c ACL-TTL-COMPUTE is not present (ACL.4th not yet loaded), the test
* is conditionally skipped and counted as a pass.
*
* Expected assertions (1, or skip):
* - @c ACL-TTL-COMPUTE returns 896 for heat=2560.
*
* @param vm VM instance.
*/
static void test_acl_adaptive_ttl(VM *vm)
{
DictEntry *e = vm_create_word(vm, "__acl_heat_test__", 17, NULL);
if (!e) { tests_failed++; return; }
/* Set heat and verify TTL-COMPUTE via FORTH (if ACL.4th loaded) */
e->execution_heat = 2560;
e->acl_allow = 1;
e->acl_pinned = 0;
DictEntry *ttl_compute = vm_find_word(vm, "ACL-TTL-COMPUTE", 15);
if (ttl_compute) {
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-TTL-COMPUTE");
vm->error = 0;
if (vm->dsp >= 0) {
cell_t ttl = vm_pop(vm);
/* heat=2560, ttl = 2560/4 + 256 = 640+256 = 896 */
ACL_ASSERT(ttl == 896, "ACL-TTL-COMPUTE: heat=2560 → ttl=896");
} else {
tests_failed++;
log_message(LOG_ERROR, " FAIL: ACL-TTL-COMPUTE left empty stack");
}
} else {
log_message(LOG_INFO, " SKIP: ACL-TTL-COMPUTE (ACL.4th not loaded)");
tests_passed++;
}
vm->error = 0;
}
/**
* @brief Test 8 — A pinned word cannot be shadowed by redefinition.
*
* Creates a word, pins it, then attempts to create another word with
* the same name via @c vm_create_word(). Verifies that the second create
* returns NULL and sets @c vm->error, and that the original pinned entry
* is still the one returned by @c vm_find_word().
*
* This enforces the Isabelle/HOL lemma @c ACL_Pin_Monotone: pin is
* permanent and cannot be overridden even by a new definition.
*
* Expected assertions (3):
* - @c vm_create_word() returns NULL for the shadowed name
* - @c vm->error is non-zero after the blocked create
* - @c vm_find_word() still returns the original pinned entry
*
* @param vm VM instance.
*/
static void test_acl_pin_blocks_shadow(VM *vm)
{
DictEntry *orig = vm_create_word(vm, "__acl_shadow_target__", 21, NULL);
if (!orig) { tests_failed++; return; }
orig->acl_pinned = 1;
DictEntry *shadow = vm_create_word(vm, "__acl_shadow_target__", 21, NULL);
ACL_ASSERT(shadow == NULL, "vm_create_word returns NULL for pinned name");
ACL_ASSERT(vm->error != 0, "vm->error set when shadow blocked");
vm->error = 0;
DictEntry *found = vm_find_word(vm, "__acl_shadow_target__", 21);
ACL_ASSERT(found == orig, "original pinned entry still found after blocked shadow");
}
/**
* @brief Test 9 — ACL-MODE@/ACL-PINNED?/ACL-TTL@/ACL-ALLOW@/ACL-HEAT@/
* ACL-WORD-ID read a word's ACL fields via the interpreter.
*
* Proof-covered field accessors (`proof/StarForth_ACL_*.thy`) that had no
* interpreter-level POST coverage before this test — every other ACL test
* in this file exercises the write accessors (`ACL-MODE!`/`ACL-TTL!`/
* `ACL-ALLOW!`) or calls the underlying C functions directly, but never
* pushed an xt and interpreted these six read words.
*
* Sets each field to a distinctive non-default value directly on a fresh
* test word, then pushes its xt and interprets each accessor in turn,
* checking the value returned on the stack.
*
* Expected assertions (6):
* - ACL-MODE@ returns @c ACL_MODE_STRICT
* - ACL-PINNED? returns -1 (true) for a pinned entry
* - ACL-TTL@ returns 4242
* - ACL-ALLOW@ returns 0 (false)
* - ACL-HEAT@ returns the entry's @c execution_heat
* - ACL-WORD-ID returns the entry's @c word_id
*
* @param vm VM instance.
*/
static void test_acl_read_accessors(VM *vm)
{
DictEntry *e = vm_create_word(vm, "__acl_read_test__", 18, NULL);
if (!e) { tests_failed++; return; }
e->acl_mode = ACL_MODE_STRICT;
e->acl_pinned = 1;
e->acl_ttl = 4242;
e->acl_allow = 0;
e->execution_heat = 777;
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-MODE@");
vm->error = 0;
ACL_ASSERT(vm_pop(vm) == (cell_t)ACL_MODE_STRICT, "ACL-MODE@ reads acl_mode");
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-PINNED?");
vm->error = 0;
ACL_ASSERT(vm_pop(vm) == -1, "ACL-PINNED? reads acl_pinned as true");
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-TTL@");
vm->error = 0;
ACL_ASSERT(vm_pop(vm) == 4242, "ACL-TTL@ reads acl_ttl");
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-ALLOW@");
vm->error = 0;
ACL_ASSERT(vm_pop(vm) == 0, "ACL-ALLOW@ reads acl_allow as false");
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-HEAT@");
vm->error = 0;
ACL_ASSERT(vm_pop(vm) == (cell_t)e->execution_heat, "ACL-HEAT@ reads execution_heat");
vm_push(vm, (cell_t)(uintptr_t)e);
vm_interpret(vm, "ACL-WORD-ID");
vm->error = 0;
ACL_ASSERT(vm_pop(vm) == (cell_t)e->word_id, "ACL-WORD-ID reads word_id");
}
/**
* @brief Test 10 — ACL-INHERIT, as an interpreted FORTH word (src dst -- ).
*
* `test_acl_inherit` above already proves the underlying
* @c acl_inherit_entry() C function is correct (Isabelle lemma
* @c ACL_Inherit_Clears_Pin) by calling it directly. This test instead
* exercises the FORTH-level dispatch path itself — pushing two xts and
* interpreting "ACL-INHERIT" — which nothing in this file previously did,
* so the word's own stack-popping/argument-order code was untested.
*
* Expected assertions (2):
* - @c dst->acl_mode == ACL_MODE_STRICT after interpreting ACL-INHERIT
* - @c dst->acl_pinned == 0 after interpreting ACL-INHERIT
*
* @param vm VM instance.
*/
static void test_acl_inherit_word_dispatch(VM *vm)
{
DictEntry *src = vm_create_word(vm, "__acl_inh_src__", 15, NULL);
DictEntry *dst = vm_create_word(vm, "__acl_inh_dst__", 15, NULL);
if (!src || !dst) { tests_failed++; return; }
src->acl_mode = ACL_MODE_STRICT;
src->acl_pinned = 0;
dst->acl_pinned = 1;
dst->acl_mode = ACL_MODE_TTL;
vm_push(vm, (cell_t)(uintptr_t)src);
vm_push(vm, (cell_t)(uintptr_t)dst);
vm_interpret(vm, "ACL-INHERIT");
vm->error = 0;
ACL_ASSERT(dst->acl_mode == ACL_MODE_STRICT, "ACL-INHERIT (word) copies acl_mode");
ACL_ASSERT(dst->acl_pinned == 0, "ACL-INHERIT (word) clears acl_pinned");
}
/**
* @brief Test 11 — ACL-INIT-PRIMITIVES resets unpinned words, skips pinned ones.
*
* Creates two fresh words with non-default ACL state: one left unpinned,
* one pinned. Interprets "ACL-INIT-PRIMITIVES" (which walks the entire
* dictionary) and verifies the unpinned word was reset to the permissive
* defaults (@c acl_ttl=0, @c acl_allow=1, @c acl_mode=ACL_MODE_TTL) while
* the pinned word's deliberately-different state was left untouched.
*
* Expected assertions (4):
* - unpinned word's @c acl_ttl reset to 0
* - unpinned word's @c acl_allow reset to 1
* - unpinned word's @c acl_mode reset to ACL_MODE_TTL
* - pinned word's @c acl_ttl is NOT reset (still its original value)
*
* @param vm VM instance.
*/
static void test_acl_init_primitives(VM *vm)
{
DictEntry *unpinned = vm_create_word(vm, "__acl_initp_free__", 19, NULL);
DictEntry *pinned = vm_create_word(vm, "__acl_initp_pin__", 18, NULL);
if (!unpinned || !pinned) { tests_failed++; return; }
unpinned->acl_ttl = 555;
unpinned->acl_allow = 0;
unpinned->acl_mode = ACL_MODE_STRICT;
unpinned->acl_pinned = 0;
pinned->acl_ttl = 555;
pinned->acl_allow = 0;
pinned->acl_mode = ACL_MODE_STRICT;
pinned->acl_pinned = 1;
vm_interpret(vm, "ACL-INIT-PRIMITIVES");
vm->error = 0;
ACL_ASSERT(unpinned->acl_ttl == 0, "ACL-INIT-PRIMITIVES resets unpinned acl_ttl");
ACL_ASSERT(unpinned->acl_allow == 1, "ACL-INIT-PRIMITIVES resets unpinned acl_allow");
ACL_ASSERT(unpinned->acl_mode == ACL_MODE_TTL, "ACL-INIT-PRIMITIVES resets unpinned acl_mode");
ACL_ASSERT(pinned->acl_ttl == 555, "ACL-INIT-PRIMITIVES leaves pinned entry untouched");
}
/* ------------------------------------------------------------------ */
/**
* @brief Module 24 entry point — run all word-level ACL POST tests.
*
* Saves the current VM state (dsp, rsp, error, mode, emergency_console)
* before each sub-test and restores it between tests so failures do not
* cascade. Runs eleven tests covering:
*
* 1. ACL-PIN one-way ratchet (4 assertions)
* 2. ACL-INHERIT semantics (4 assertions)
* 3. emergency_console bypass (1 assertion)
* 4. ACL denial aborts word execution (2 assertions)
* 5. TTL hot-path decrement (1 assertion)
* 6. STRICT mode — TTL stays 0 (1 assertion or conditional skip)
* 7. Adaptive TTL via ACL-TTL-COMPUTE (1 assertion or conditional skip)
* 8. Pin blocks shadowing (3 assertions)
* 9. Read accessors — ACL-MODE@/PINNED?/TTL@/ALLOW@/HEAT@/WORD-ID (6 assertions)
* 10. ACL-INHERIT as an interpreted word, not just its C twin (2 assertions)
* 11. ACL-INIT-PRIMITIVES resets unpinned, skips pinned (4 assertions)
*
* Tests that depend on @c ACL.4th being loaded are conditionally skipped
* during bare POST (before @c ACL.4th runs) and counted as passes so the
* POST score is not penalised by load-order.
*
* @param vm VM instance; must be initialised and have the standard
* word vocabulary available.
*/
void run_acl_words_tests(VM *vm)
{
log_message(LOG_INFO, "Running ACL Words Tests (Module 24)...");
tests_passed = 0;
tests_failed = 0;
int saved_dsp, saved_rsp, saved_error;
vm_mode_t saved_mode;
save_vm_state(vm, &saved_dsp, &saved_rsp, &saved_error, &saved_mode);
uint8_t saved_ec = vm->emergency_console;
test_acl_pin_immutable(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_acl_inherit(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_emergency_console_bypass(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_acl_deny_aborts(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_acl_ttl_hot_path(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_acl_strict_mode(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_acl_adaptive_ttl(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_acl_pin_blocks_shadow(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_acl_read_accessors(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_acl_inherit_word_dispatch(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
test_acl_init_primitives(vm);
restore_vm_state(vm, saved_dsp, saved_rsp, 0, saved_mode);
vm->emergency_console = saved_ec;
print_module_summary("ACL Words", tests_passed, tests_failed, 0, 0);
}
v3/src/test_runner/modules/arithmetic_words_test.c
+285
View File
@@ -0,0 +1,285 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/* Arithmetic Words Test Suites - Module 5 */
static WordTestSuite arithmetic_word_suites[] = {
{
"+", {
{"basic", "5 7 + . CR", "Should print: 12", TEST_NORMAL, 0, 1, {0}},
{"zero_add", "42 0 + . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-5 3 + . CR", "Should print: -2", TEST_NORMAL, 0, 1, {0}},
{"both_negative", "-5 -3 + . CR", "Should print: -8", TEST_NORMAL, 0, 1, {0}},
{"overflow", "2147483647 1 + . CR", "Should overflow", TEST_EDGE_CASE, 0, 1, {0}},
{"underflow", "-2147483648 -1 + . CR", "Should underflow", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "+", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 +", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
8, {0}
},
{
"-", {
{"basic", "10 3 - . CR", "Should print: 7", TEST_NORMAL, 0, 1, {0}},
{"zero_sub", "42 0 - . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"from_zero", "0 5 - . CR", "Should print: -5", TEST_NORMAL, 0, 1, {0}},
{"negative", "5 -3 - . CR", "Should print: 8", TEST_NORMAL, 0, 1, {0}},
{"same_values", "42 42 - . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"overflow", "-2147483648 1 - . CR", "Should underflow", TEST_EDGE_CASE, 0, 1, {0}},
{"underflow", "2147483647 -1 - . CR", "Should overflow", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "-", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 -", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
9, {0}
},
{
"*", {
{"basic", "6 7 * . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"by_zero", "42 0 * . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"by_one", "42 1 * . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"by_negative", "6 -7 * . CR", "Should print: -42", TEST_NORMAL, 0, 1, {0}},
{"negative_negative", "-6 -7 * . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"large_numbers", "32767 2 * . CR", "Should print: 65534", TEST_EDGE_CASE, 0, 1, {0}},
{"overflow", "65536 65536 * . CR", "May overflow", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "*", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 *", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
9, {0}
},
{
"/", {
{"basic", "15 3 / . CR", "Should print: 5", TEST_NORMAL, 0, 1, {0}},
{"by_one", "42 1 / . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"negative_dividend", "-15 3 / . CR", "Should print: -5", TEST_NORMAL, 0, 1, {0}},
{"negative_divisor", "15 -3 / . CR", "Should print: -5", TEST_NORMAL, 0, 1, {0}},
{"both_negative", "-15 -3 / . CR", "Should print: 5", TEST_NORMAL, 0, 1, {0}},
{"truncation", "7 3 / . CR", "Should print: 2 (truncated)", TEST_NORMAL, 0, 1, {0}},
{"by_zero", "42 0 /", "Should cause division by zero", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "/", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 /", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
9, {0}
},
{
"MOD", {
{"basic", "17 5 MOD . CR", "Should print: 2", TEST_NORMAL, 0, 1, {0}},
{"exact_division", "15 3 MOD . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"by_one", "42 1 MOD . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative_dividend", "-17 5 MOD . CR", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{"negative_divisor", "17 -5 MOD . CR", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{"small_by_large", "3 7 MOD . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{"by_zero", "42 0 MOD", "Should cause division by zero", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "MOD", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 MOD", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
9, {0}
},
{
"/MOD", {
{"basic", "17 5 /MOD . . CR", "Should print: 3 2", TEST_NORMAL, 0, 1, {0}},
{"exact", "15 3 /MOD . . CR", "Should print: 5 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-17 5 /MOD . . CR","Should handle negative dividend", TEST_NORMAL, 0, 1, {0}},
{"by_zero", "42 0 /MOD", "Should cause division by zero", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "/MOD", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 /MOD", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"ABS", {
{"positive", "42 ABS . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-42 ABS . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 ABS . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"min_int", "-2147483648 ABS . CR", "Should print: 2147483648", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "ABS", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"NEGATE", {
{"positive", "42 NEGATE . CR", "Should print: -42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-42 NEGATE . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 NEGATE . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"min_int", "-2147483648 NEGATE . CR", "Should print: 2147483648", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "NEGATE", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"MIN", {
{"basic", "5 3 MIN . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{"equal", "42 42 MIN . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-5 -3 MIN . CR", "Should print: -5", TEST_NORMAL, 0, 1, {0}},
{"mixed", "-1 1 MIN . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"one_item", "42 MIN", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "MIN", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"MAX", {
{"basic", "5 3 MAX . CR", "Should print: 5", TEST_NORMAL, 0, 1, {0}},
{"equal", "42 42 MAX . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-5 -3 MAX . CR", "Should print: -3", TEST_NORMAL, 0, 1, {0}},
{"mixed", "-1 1 MAX . CR", "Should print: 1", TEST_NORMAL, 0, 1, {0}},
{"one_item", "42 MAX", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "MAX", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"1+", {
{"basic", "5 1+ . CR", "Should print: 6", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 1+ . CR", "Should print: 1", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 1+ . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"chain", "3 1+ 1+ 1+ . CR", "Should print: 6", TEST_NORMAL, 0, 1, {0}},
{"overflow", "2147483647 1+ . CR", "Should overflow", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "1+", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"1-", {
{"basic", "5 1- . CR", "Should print: 4", TEST_NORMAL, 0, 1, {0}},
{"to_zero", "1 1- . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"to_negative", "0 1- . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"chain", "6 1- 1- 1- . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{"underflow", "-2147483648 1- . CR", "Should underflow", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "1-", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"2+", {
{"basic", "5 2+ . CR", "Should print: 7", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 2+ . CR", "Should print: 2", TEST_NORMAL, 0, 1, {0}},
{"negative", "-3 2+ . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "2+", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"2-", {
{"basic", "7 2- . CR", "Should print: 5", TEST_NORMAL, 0, 1, {0}},
{"zero", "2 2- . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "0 2- . CR", "Should print: -2", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "2-", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"2*", {
{"basic", "5 2* . CR", "Should print: 10", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 2* . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-3 2* . CR", "Should print: -6", TEST_NORMAL, 0, 1, {0}},
{"one", "1 2* . CR", "Should print: 2", TEST_NORMAL, 0, 1, {0}},
{"large", "1073741823 2* . CR", "Should print: 2147483646", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "2*", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"2/", {
{"basic", "10 2/ . CR", "Should print: 5", TEST_NORMAL, 0, 1, {0}},
{"odd", "7 2/ . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 2/ . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative_even", "-10 2/ . CR", "Should print: -5", TEST_NORMAL, 0, 1, {0}},
{"one", "1 2/ . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "2/", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all arithmetic word test suites
* @param vm Pointer to the Forth virtual machine instance
* @details Runs through all test cases for arithmetic operations including
* basic operations (+, -, *, /), modulo operations (MOD, /MOD),
* and numeric functions (ABS, NEGATE, MIN, MAX)
*/
void run_arithmetic_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Arithmetic Words Tests (Module 5)...");
WordContract mod = {CONTRACT_PHYSICS_TRANSPARENT, 0};
for (int i = 0; arithmetic_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite_m(vm, &arithmetic_word_suites[i], mod);
}
print_module_summary("Arithmetic Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/block_words_test.c
+213
View File
@@ -0,0 +1,213 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/**
* @brief Test suites for FORTH block words (Module 16)
*
* Contains test cases for the following FORTH words:
* - BLOCK: Block access
* - BUFFER: Buffer management
* - UPDATE: Block modification marking
* - SAVE-BUFFERS: Buffer flushing
* - EMPTY-BUFFERS: Buffer invalidation
* - FLUSH: Buffer saving and invalidation
* - LOAD: Block interpretation
* - LIST: Block display
* - SCR: Current block number
* - THRU: Load block range
* - -->: Continue to next block
*/
static WordTestSuite block_word_suites[] = {
{
"BLOCK", {
{"basic", "1 BLOCK DUP . CR", "Should return block address", TEST_NORMAL, 0, 1, {0}},
{"zero_block", "0 BLOCK", "Should handle block 0", TEST_ERROR_CASE, 1, 1, {0}},
{"large_block", "65536 BLOCK", "Should handle large number", TEST_ERROR_CASE, 1, 1, {0}},
{"negative", "-1 BLOCK", "Should handle negative", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "BLOCK", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"BUFFER", {
{"basic", "1 BUFFER DUP . CR", "Should return buffer address", TEST_NORMAL, 0, 1, {0}},
{"zero_block", "0 BUFFER", "Should handle block 0", TEST_ERROR_CASE, 1, 1, {0}},
{"flush_dirty", "2 BLOCK 1+ 2 BUFFER", "Should flush if dirty", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "BUFFER", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"UPDATE", {
{"basic", "1 BLOCK UPDATE", "Should mark block dirty", TEST_NORMAL, 0, 1, {0}},
{"multiple", "1 BLOCK UPDATE UPDATE", "Should handle multiple updates", TEST_NORMAL, 0, 1, {0}},
{"no_block", "0 SCR ! UPDATE", "Should error: blk=0 is invalid", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"SAVE-BUFFERS", {
{"basic", "SAVE-BUFFERS", "Should flush all buffers", TEST_NORMAL, 0, 1, {0}},
{"dirty_blocks", "1 BLOCK UPDATE SAVE-BUFFERS", "Should save dirty blocks", TEST_NORMAL, 0, 1, {0}},
{"no_dirty", "SAVE-BUFFERS", "Should handle no dirty blocks", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"EMPTY-BUFFERS", {
{"basic", "EMPTY-BUFFERS", "Should invalidate all buffers", TEST_NORMAL, 0, 1, {0}},
{"after_use", "1 BLOCK EMPTY-BUFFERS", "Should invalidate used buffers", TEST_NORMAL, 0, 1, {0}},
{"dirty_blocks", "1 BLOCK UPDATE EMPTY-BUFFERS", "Should handle dirty blocks", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"FLUSH", {
{"basic", "FLUSH", "Should save and invalidate buffers", TEST_NORMAL, 0, 1, {0}},
{"dirty_blocks", "1 BLOCK UPDATE FLUSH", "Should flush dirty blocks", TEST_NORMAL, 0, 1, {0}},
{"after_empty", "EMPTY-BUFFERS FLUSH", "Should handle empty buffers", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"LOAD", {
{"basic", "1 LOAD", "Should interpret block 1", TEST_NORMAL, 0, 1, {0}},
{"zero_block", "0 LOAD", "Should handle block 0", TEST_ERROR_CASE, 1, 1, {0}},
{"nonexistent", "9999 LOAD", "Should handle missing block", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "LOAD", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"LIST", {
{"basic", "1 LIST", "Should display block 1", TEST_NORMAL, 0, 1, {0}},
{"zero_block", "0 LIST", "Should handle block 0", TEST_ERROR_CASE, 1, 1, {0}},
{"nonexistent", "9999 LIST", "Should handle missing block", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "LIST", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"SCR", {
{"basic", "SCR @ . CR", "Should show current block", TEST_NORMAL, 0, 1, {0}},
{"after_list", "1 LIST SCR @ . CR", "Should update after LIST", TEST_NORMAL, 0, 1, {0}},
{"after_load", "1 LOAD SCR @ . CR", "Should update after LOAD", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"THRU", {
/* Basic functionality */
{"single_block", "1 1 THRU", "Should load single block (1-1)", TEST_NORMAL, 0, 1, {0}},
{"ascending", "1 3 THRU", "Should load blocks 1-3 in order", TEST_NORMAL, 0, 1, {0}},
{"descending", "3 1 THRU", "Should auto-swap and load 1-3", TEST_NORMAL, 0, 1, {0}},
{"same_block", "2 2 THRU", "Should load single block (2-2)", TEST_NORMAL, 0, 1, {0}},
/* Error cases - invalid block numbers */
{"zero_start", "0 3 THRU", "Should reject block 0 as start", TEST_ERROR_CASE, 1, 1, {0}},
{"zero_end", "1 0 THRU", "Should reject block 0 as end", TEST_ERROR_CASE, 1, 1, {0}},
{"both_zero", "0 0 THRU", "Should reject both blocks as 0", TEST_ERROR_CASE, 1, 1, {0}},
{"invalid_start", "9999 10000 THRU", "Should reject invalid start block", TEST_ERROR_CASE, 1, 1, {0}},
{"invalid_end", "1 9999 THRU", "Should reject invalid end block", TEST_ERROR_CASE, 1, 1, {0}},
{"both_invalid", "9998 9999 THRU", "Should reject both invalid blocks", TEST_ERROR_CASE, 1, 1, {0}},
/* Stack underflow */
{"empty_stack", "THRU", "Should cause stack underflow (no args)", TEST_ERROR_CASE, 1, 1, {0}},
{"one_arg", "1 THRU", "Should cause stack underflow (one arg)", TEST_ERROR_CASE, 1, 1, {0}},
/* Range tests */
{"small_range", "1 2 THRU", "Should load 2-block range", TEST_NORMAL, 0, 1, {0}},
{"medium_range", "1 5 THRU", "Should load 5-block range", TEST_NORMAL, 0, 1, {0}},
/* Edge cases */
{"negative_start", "-1 3 THRU", "Should handle negative start", TEST_ERROR_CASE, 1, 1, {0}},
{"negative_end", "1 -3 THRU", "Should handle negative end", TEST_ERROR_CASE, 1, 1, {0}},
{"both_negative", "-3 -1 THRU", "Should handle both negative", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
17, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all block words test suites
* @param vm Pointer to the FORTH virtual machine instance
*
* Runs through all test cases for block manipulation words, including
* block access, buffer management, and block I/O operations. Results
* are logged and summarized after completion.
*/
void run_block_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Block Words Tests (Module 16)...");
for (int i = 0; block_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &block_word_suites[i]);
}
print_module_summary("Block Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/break_me_tests.c
+202
View File
@@ -0,0 +1,202 @@
/*
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 <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include "test_runner.h"
#include "../../../include/log.h"
#include "../../../include/vm.h"
/* Report file handle */
static FILE *report_file = NULL;
static time_t test_start_time;
static time_t test_end_time;
static int total_tests_run = 0;
/**
* @brief Initialize markdown report file
*/
static int init_report(void) {
time(&test_start_time);
report_file = fopen("docs/BREAK_ME_REPORT.md", "w");
if (!report_file) {
log_message(LOG_ERROR, "Failed to create BREAK_ME_REPORT.md");
return -1;
}
char time_str[64];
struct tm *tm_info = localtime(&test_start_time);
strftime(time_str, sizeof(time_str), "%Y-%m-%d %H:%M:%S", tm_info);
fprintf(report_file, "# 🔥 STARFORTH BREAK-ME DIAGNOSTIC REPORT 🔥\n\n");
fprintf(report_file, "## Executive Summary\n\n");
fprintf(report_file, "**Generated:** %s\n\n", time_str);
fprintf(report_file, "**Test Mode:** ULTRA-COMPREHENSIVE DIAGNOSTIC\n\n");
fprintf(report_file, "**Purpose:** This report documents the results_run_01_2025_12_08 of the most exhaustive ");
fprintf(report_file, "testing suite ever run on StarForth. Every word, every edge case, ");
fprintf(report_file, "every pathological scenario has been tested to ensure rock-solid ");
fprintf(report_file, "reliability and FORTH-79 standard compliance.\n\n");
fprintf(report_file, "---\n\n");
return 0;
}
/**
* @brief Finalize report with system info and easter egg
*/
static void finalize_report(VM *vm) {
time(&test_end_time);
if (!report_file) return;
/* Performance metrics */
fprintf(report_file, "\n## 📊 Performance Metrics\n\n");
fprintf(report_file, "| Metric | Value |\n");
fprintf(report_file, "|--------|-------|\n");
fprintf(report_file, "| Test Duration | %.2f seconds |\n", difftime(test_end_time, test_start_time));
fprintf(report_file, "| Total Tests | %d |\n", total_tests_run);
fprintf(report_file, "| Tests/Second | %.2f |\n\n",
total_tests_run / difftime(test_end_time, test_start_time));
/* System info */
fprintf(report_file, "## 🖥️ System Information\n\n");
fprintf(report_file, "| Component | Specification |\n");
fprintf(report_file, "|-----------|---------------|\n");
fprintf(report_file, "| VM Architecture | Direct-threaded |\n");
fprintf(report_file, "| Standard | FORTH-79 + StarForth Extensions |\n");
fprintf(report_file, "| Cell Size | %zu bytes |\n", sizeof(cell_t));
fprintf(report_file, "| Stack Size | %d cells |\n", STACK_SIZE);
fprintf(report_file, "| Memory | %d bytes |\n\n", VM_MEMORY_SIZE);
/* Easter egg */
fprintf(report_file, "\n---\n\n");
fprintf(report_file, "## 🎉 EASTER EGG: THE STARFORTH CHALLENGE 🎉\n\n");
fprintf(report_file, "```\n");
fprintf(report_file, " ⭐ C O N G R A T U L A T I O N S ⭐\n\n");
fprintf(report_file, " You've discovered the hidden StarForth challenge!\n\n");
fprintf(report_file, " Your system just survived %d exhaustive tests.\n", total_tests_run);
fprintf(report_file, " But can YOU survive the ULTIMATE FORTH CHALLENGE?\n\n");
fprintf(report_file, " 🏆 THE STARFORTH MASTER CHALLENGE 🏆\n\n");
fprintf(report_file, " Write a Forth program that:\n");
fprintf(report_file, " 1. Prints the Fibonacci sequence up to 1000\n");
fprintf(report_file, " 2. Uses ONLY the following words:\n");
fprintf(report_file, " : ; DUP OVER DROP SWAP . CR < IF THEN DO LOOP\n");
fprintf(report_file, " 3. Fits in exactly 79 characters (FORTH-79 tribute!)\n\n");
fprintf(report_file, " Submit your solution to the StarForth community!\n\n");
fprintf(report_file, " Hint: Think recursively, but remember FORTH-79\n");
fprintf(report_file, " doesn't have RECURSE... 😉\n\n");
fprintf(report_file, " ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━\n\n");
fprintf(report_file, " BONUS SECRET: If you ran --break-me, you're already\n");
fprintf(report_file, " in the top 1%% of Forth enthusiasts. Welcome to the\n");
fprintf(report_file, " elite club! Your system just proved it can handle\n");
fprintf(report_file, " anything you throw at it.\n\n");
fprintf(report_file, " May your stacks be balanced and your words defined,\n");
fprintf(report_file, " -- The StarForth Development Team ⭐\n");
fprintf(report_file, "```\n\n");
fprintf(report_file, "### 🎮 More Easter Eggs to Find:\n\n");
fprintf(report_file, "1. Try defining a word called `STARSHIP` and see what happens\n");
fprintf(report_file, "2. Run `42 ENTROPY@ .` to see the universe's favorite number\n");
fprintf(report_file, "3. Type `WORDS` and count how many contain 'STAR'\n");
fprintf(report_file, "4. Check what happens when you `FORGET FORGET` (just kidding, don't!)\n\n");
fprintf(report_file, "---\n\n");
fprintf(report_file, "*Generated by StarForth --break-me mode*\n");
fprintf(report_file, "*Copyright (c) 2025 Robert A. James - StarshipOS Forth Project*\n");
fclose(report_file);
report_file = NULL;
}
/**
* @brief Main entry point for --break-me mode
*/
void run_break_me_tests(VM *vm) {
if (!vm) return;
log_message(LOG_INFO, "");
log_message(LOG_INFO, "╔═══════════════════════════════════════════════════════════╗");
log_message(LOG_INFO, "║ ║");
log_message(LOG_INFO, "║ 🔥 BREAK-ME MODE ACTIVATED 🔥 ║");
log_message(LOG_INFO, "║ ║");
log_message(LOG_INFO, "║ Ultra-Comprehensive StarForth Diagnostic Suite ║");
log_message(LOG_INFO, "║ ║");
log_message(LOG_INFO, "║ Preparing to execute EXHAUSTIVE test battery... ║");
log_message(LOG_INFO, "║ Generating detailed markdown report... ║");
log_message(LOG_INFO, "║ Surprise easter egg awaits at the end! ║");
log_message(LOG_INFO, "║ ║");
log_message(LOG_INFO, "╚═══════════════════════════════════════════════════════════╝");
log_message(LOG_INFO, "");
/* Initialize report */
if (init_report() != 0) {
log_message(LOG_ERROR, "Failed to initialize report - aborting");
return;
}
/* Run ALL existing test suites */
log_message(LOG_INFO, "Running comprehensive test suite...");
run_all_tests(vm);
/* Update counter from global stats */
extern TestStats global_test_stats;
total_tests_run = global_test_stats.total_tests;
/* Finalize report */
finalize_report(vm);
log_message(LOG_INFO, "");
log_message(LOG_INFO, "╔═══════════════════════════════════════════════════════════╗");
log_message(LOG_INFO, "║ ║");
log_message(LOG_INFO, "║ ✅ BREAK-ME COMPLETE ✅ ║");
log_message(LOG_INFO, "║ ║");
log_message(LOG_INFO, "║ StarForth survived %d tests! ║", total_tests_run);
log_message(LOG_INFO, "║ Check docs/BREAK_ME_REPORT.md for full details ║");
log_message(LOG_INFO, "║ ║");
log_message(LOG_INFO, "║ 🎉 Don't forget to read the easter egg! 🎉 ║");
log_message(LOG_INFO, "║ ║");
log_message(LOG_INFO, "╚═══════════════════════════════════════════════════════════╝");
log_message(LOG_INFO, "");
}
v3/src/test_runner/modules/control_words_test.c
+267
View File
@@ -0,0 +1,267 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/** @brief Test suites for FORTH control words
* @details Contains test cases for all control flow words in Module 12,
* including conditional branches and loop structures
*/
static WordTestSuite control_word_suites[] = {
{
"IF", {
{"true", ": TEST1 IF 42 ELSE 24 THEN ; -1 TEST1 . CR", "Should take true branch", TEST_NORMAL, 0, 1, {0}},
{"false", ": TEST2 IF 42 ELSE 24 THEN ; 0 TEST2 . CR", "Should take false branch", TEST_NORMAL, 0, 1, {0}},
{
"nested", ": TEST3 IF IF 1 ELSE 2 THEN ELSE 3 THEN ; -1 -1 TEST3 . CR", "Should handle nesting",
TEST_NORMAL, 0, 1, {0}
},
{"no_else", ": TEST4 IF 42 THEN ; -1 TEST4 . CR", "Should work without ELSE", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "IF", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"ELSE", {
{"alone", "ELSE", "Should error outside IF", TEST_ERROR_CASE, 1, 1, {0}},
{"double", ": BAD IF 1 ELSE ELSE 2 THEN ;", "Should prevent double ELSE", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"THEN", {
{"alone", "THEN", "Should error outside IF", TEST_ERROR_CASE, 1, 1, {0}},
{"extra", ": BAD IF 1 THEN THEN ;", "Should prevent extra THEN", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"BEGIN", {
{"until", ": TEST5 0 BEGIN 1+ DUP 5 = UNTIL ; TEST5 . CR", "Should loop until true", TEST_NORMAL, 0, 1, {0}},
{
"while", ": TEST6 0 BEGIN DUP 5 < WHILE 1+ REPEAT ; TEST6 . CR", "Should loop while true", TEST_NORMAL, 0, 1, {0}
},
/* TODO: Nested control flow - needs compiler refactoring for proper origin stack */
/* {"nested", ": TEST7 0 BEGIN 1+ BEGIN DUP 3 < WHILE 1+ REPEAT DUP 5 = UNTIL ;", "Should handle nesting", TEST_NORMAL, 0, 1}, */
{"alone", "BEGIN", "Should error outside definition", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"UNTIL", {
{"basic", ": TEST8 BEGIN DUP 1- DUP 0= UNTIL ; 5 TEST8 . CR", "Should count down", TEST_NORMAL, 0, 1, {0}},
{"immediate", ": TEST9 BEGIN 1 UNTIL ; IMMEDIATE", "Should be immediate", TEST_NORMAL, 0, 1, {0}},
{"no_begin", "UNTIL", "Should error without BEGIN", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"WHILE", {
{"basic", ": TEST10 BEGIN DUP 5 < WHILE 1+ REPEAT ; 0 TEST10 . CR", "Should count up", TEST_NORMAL, 0, 1, {0}},
{
"zero_times", ": TEST11 BEGIN DUP 0< WHILE 1+ REPEAT ; 0 TEST11 . CR", "Should handle zero iterations",
TEST_NORMAL, 0, 1, {0}
},
{"no_begin", "WHILE", "Should error without BEGIN", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"REPEAT", {
{
"basic", ": TEST12 BEGIN DUP 5 < WHILE 1+ REPEAT ; 0 TEST12 . CR", "Should terminate loop", TEST_NORMAL, 0, 1, {0}
},
{"no_while", "REPEAT", "Should error without WHILE", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"DO", {
{"basic", ": TEST13 5 0 DO I . LOOP ; TEST13 CR", "Should count 0 to 4", TEST_NORMAL, 0, 1, {0}},
{"negative", ": TEST14 -1 -5 DO I . LOOP ; TEST14 CR", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{"empty", ": TEST15 0 0 DO LOOP ;", "Should handle empty range", TEST_NORMAL, 0, 1, {0}},
{
"nested", ": TEST16 3 0 DO 3 0 DO J I + . LOOP LOOP ; TEST16 CR", "Should handle nesting", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"?DO", {
{"basic", ": TEST17 5 0 ?DO I . LOOP ; TEST17 CR", "Should count 0 to 4", TEST_NORMAL, 0, 1, {0}},
{"skip", ": TEST18 1 1 ?DO I . LOOP ;", "Should skip when equal", TEST_NORMAL, 0, 1, {0}},
{
"nested", ": TEST19 3 0 ?DO 3 I ?DO J I + . LOOP LOOP ; TEST19 CR", "Should handle nesting",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"LOOP", {
{"basic", ": TEST20 5 0 DO I . LOOP ; TEST20 CR", "Should increment by 1", TEST_NORMAL, 0, 1, {0}},
{"no_do", "LOOP", "Should error without DO", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"+LOOP", {
{"basic", ": TEST21 10 0 DO I . 2 +LOOP ; TEST21 CR", "Should count by 2", TEST_NORMAL, 0, 1, {0}},
{"negative", ": TEST22 0 10 DO I . -1 +LOOP ; TEST22 CR", "Should count down", TEST_NORMAL, 0, 1, {0}},
{"variable", ": TEST23 10 0 DO I . DUP +LOOP ; 3 TEST23 CR", "Should use stack value", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"I", {
{"basic", ": TI 4 0 DO I . LOOP CR ; TI", "Should print: 0 1 2 3", TEST_NORMAL, 0, 1, {0}},
{"single", ": TI1 1 0 DO I . LOOP CR ; TI1", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"offset", ": TI2 5 3 DO I . LOOP CR ; TI2", "Should print: 3 4", TEST_NORMAL, 0, 1, {0}},
{"in_expr", ": TI3 3 0 DO I 2 * . LOOP CR ; TI3", "Should print: 0 2 4", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"J", {
{"basic", ": TJ 2 0 DO 3 0 DO J . LOOP LOOP CR ; TJ", "Should print: 0 0 0 1 1 1", TEST_NORMAL, 0, 1, {0}},
{"paired", ": TJ2 2 0 DO 2 0 DO J I + . LOOP LOOP CR ; TJ2", "Should print: 0 1 1 2", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"EXIT", {
{"early_return", ": TEX 5 EXIT 99 ; TEX . CR", "Should print: 5", TEST_NORMAL, 0, 1, {0}},
{"cond_exit_pos", ": TEX2 DUP 0> IF EXIT THEN NEGATE ; 3 TEX2 . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{"cond_exit_neg", ": TEX2 DUP 0> IF EXIT THEN NEGATE ; -4 TEX2 . CR", "Should print: 4", TEST_NORMAL, 0, 1, {0}},
{"no_skipped", ": TEX3 1 2 EXIT 3 ; TEX3 . . CR", "Should print: 2 1", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"LEAVE", {
{"basic", ": TLV 0 5 0 DO I 3 = IF LEAVE THEN 1+ LOOP ; TLV . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{"at_start", ": TLV2 0 5 0 DO LEAVE 1+ LOOP ; TLV2 . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"qdloop", ": TLV3 0 5 0 ?DO I 2 = IF LEAVE THEN 1+ LOOP ; TLV3 . CR", "Should print: 2", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"UNLOOP", {
{"early_exit", ": TUL 5 0 DO I 2 = IF UNLOOP 42 EXIT THEN LOOP 99 ; TUL . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"full_loop", ": TUL2 5 0 DO I 9 = IF UNLOOP 77 EXIT THEN LOOP 99 ; TUL2 . CR", "Should print: 99", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"AGAIN", {
{"basic", ": TAG 0 BEGIN 1+ DUP 3 = IF EXIT THEN AGAIN ; TAG . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{"countdown",": CD 10 BEGIN 1- DUP 0= IF EXIT THEN AGAIN ; CD . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"CASE", {
{"match_1", ": TC CASE 1 OF 10 ENDOF 2 OF 20 ENDOF 99 SWAP ENDCASE . CR ; 1 TC", "Should print: 10", TEST_NORMAL, 0, 1, {0}},
{"match_2", ": TC CASE 1 OF 10 ENDOF 2 OF 20 ENDOF 99 SWAP ENDCASE . CR ; 2 TC", "Should print: 20", TEST_NORMAL, 0, 1, {0}},
{"default", ": TC CASE 1 OF 10 ENDOF 2 OF 20 ENDOF 99 SWAP ENDCASE . CR ; 5 TC", "Should print: 99", TEST_NORMAL, 0, 1, {0}},
{"zero_case", ": TC CASE 0 OF 88 ENDOF 1 OF 77 ENDOF 66 SWAP ENDCASE . CR ; 0 TC", "Should print: 88", TEST_NORMAL, 0, 1, {0}},
{"neg_case", ": TC CASE -1 OF 55 ENDOF 44 SWAP ENDCASE . CR ; -1 TC", "Should print: 55", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/** @brief Executes all control words test suites
* @param vm Pointer to the FORTH virtual machine instance
* @details Runs through all defined test cases for control words,
* testing conditional branches and loop constructs
*/
void run_control_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Control Words Tests (Module 12)...");
for (int i = 0; control_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &control_word_suites[i]);
run_test_suite(vm, &control_word_suites[i]);
}
print_module_summary("Control Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/defining_words_tests.c
+191
View File
@@ -0,0 +1,191 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/** @brief Test suites for Forth defining words (Module 13)
* @details Contains test cases for core defining words including:
* :, ;, CONSTANT, VARIABLE, CREATE, DOES>, [, and ]
*/
static WordTestSuite defining_word_suites[] = {
{
":", {
{"basic", ": TEST1 42 ; TEST1 . CR", "Should define and execute", TEST_NORMAL, 0, 1, {0}},
{"empty_name", ":", "Should handle empty definition", TEST_ERROR_CASE, 1, 1, {0}},
{"nested", ": TEST3 : ;", "Should prevent nested definition", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
";", {
{"alone", ";", "Should error outside definition", TEST_ERROR_CASE, 1, 1, {0}},
{"immediate", ": TEST4 42 ; IMMEDIATE TEST4 . CR", "Should handle immediate", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"CONSTANT", {
{"basic", "42 CONSTANT MEANING MEANING . CR", "Should create constant", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 CONSTANT ZERO ZERO . CR", "Should handle zero", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 CONSTANT MINUS MINUS . CR", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "CONSTANT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"VARIABLE", {
{"basic", "VARIABLE VAR1 42 VAR1 ! VAR1 @ . CR", "Should create variable", TEST_NORMAL, 0, 1, {0}},
{"multiple", "VARIABLE VAR2 VARIABLE VAR3", "Should create multiple", TEST_NORMAL, 0, 1, {0}},
{"store_fetch", "VARIABLE VAR4 -99 VAR4 ! VAR4 @ . CR", "Should store/fetch", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"CREATE", {
{"basic", "CREATE OBJ1", "Should create word", TEST_NORMAL, 0, 1, {0}},
{"with_data", "CREATE OBJ2 42 , OBJ2 @ . CR", "Should allow data", TEST_NORMAL, 0, 1, {0}},
{"empty_name", "CREATE", "Should handle empty name", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"DOES>", {
{
"basic", ": CONST CREATE , DOES> @ ; 42 CONST MEANING MEANING . CR", "Should define behavior",
TEST_NORMAL, 0, 1, {0}
},
{
"multiple", ": ARRAY CREATE DOES> SWAP CELLS + ; CREATE ARR 10 CELLS ALLOT", "Should work with arrays",
TEST_NORMAL, 0, 1, {0}
},
{"outside", "DOES>", "Should error outside definition", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"[", {
{"basic", ": TEST5 [ 42 ] LITERAL ; TEST5 . CR", "Should enter interpret", TEST_NORMAL, 0, 1, {0}},
{"outside", "[", "Should be allowed outside definition (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"]", {
{"basic", "[ 42 ] . CR", "Should resume compile", TEST_NORMAL, 0, 1, {0}},
{"nested", ": TEST6 [ ] 42 ; TEST6 . CR", "Should handle nesting", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"DEFER", {
{"basic", "DEFER DF1 : DF1W 42 . CR ; ' DF1W IS DF1 DF1", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"uninit", "DEFER DF2 DF2", "Should error: uninitialized deferred word", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"IS", {
{"basic", "DEFER IS1 : IS1W 99 . CR ; ' IS1W IS IS1 IS1", "Should print: 99", TEST_NORMAL, 0, 1, {0}},
{"not_defer", "42 IS DUP", "Should error: DUP is not a DEFER word", TEST_ERROR_CASE, 1, 1, {0}},
{"not_found", "42 IS NOSUCH", "Should error: word not found", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"DEFER@", {
{"basic", "DEFER DFA1 : DFA1W 7 . CR ; ' DFA1W IS DFA1 DEFER@ DFA1 0<> . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"not_found", "DEFER@ NOSUCH2", "Should error: word not found", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"[']", {
{"compile_xt", ": BKT1 ['] DUP ; 77 BKT1 EXECUTE . . CR", "Should print: 77 77", TEST_NORMAL, 0, 1, {0}},
{"pin_like", ": BKT2 ['] DROP ; 1 2 BKT2 EXECUTE . CR", "Should print: 1", TEST_NORMAL, 0, 1, {0}},
{"not_found", ": BKT3 ['] NOSUCHWORD ;", "Should error: word not found", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/** @brief Executes all test suites for Forth defining words
* @param vm Pointer to the Forth virtual machine instance
* @details Runs through each test suite in defining_word_suites array,
* executing individual test cases and logging results_run_01_2025_12_08
*/
void run_defining_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Defining Words Tests (Module 13)...");
for (int i = 0; defining_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &defining_word_suites[i]);
}
print_module_summary("Defining Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/dictionary_manipulation_words_test.c
+194
View File
@@ -0,0 +1,194 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/* Dictionary Manipulation Words Test Suites - Module 14 */
static WordTestSuite dict_manip_word_suites[] = {
{
"CREATE", {
{"basic", "CREATE test1 42 , test1 @ . CR", "Should create and store", TEST_NORMAL, 0, 1, {0}},
{"empty_name", "CREATE", "Should handle empty name", TEST_ERROR_CASE, 1, 1, {0}},
{
"redefine_shadows", "CREATE T 1 , CREATE T 2 , T @ . CR", "Newest definition should win (prints 2)",
TEST_NORMAL, 0, 1, {0}
},
{"duplicate", "CREATE test2 CREATE test2", "Should allow redefinition (latest shadows)", TEST_NORMAL, 0, 1, {0}},
{"long_name", "CREATE abcdefghijklmnopqrstuvwxyz", "Should handle long name", TEST_EDGE_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"FORGET", {
{"basic", "CREATE temp1 FORGET temp1", "Should forget word", TEST_NORMAL, 0, 1, {0}},
{"nonexistent", "FORGET nonexistent", "Should handle missing word", TEST_ERROR_CASE, 1, 1, {0}},
{"protected", "FORGET FORGET", "Should protect system words", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
/* FENCE ( -- ): raises the FORGET boundary to the current dictionary
* top. Added alongside a real bug fix in FORGET itself, caught while
* building this word -- forgetting the single newest word used to
* incorrectly destroy every other word back to the fence too (a
* use-after-free in the relink logic, not just an off-by-one), a
* SIGSEGV in the worst case. "forget_latest_keeps_predecessor" below
* is exactly the regression case that fix addresses. */
"FENCE", {
{
"basic", "CREATE fnc1 FENCE CREATE fnc2 FORGET fnc2",
"Should forget a word defined after FENCE", TEST_NORMAL, 0, 1, {0}
},
{
"protects_older", "CREATE fnc3 CREATE fnc4 FENCE FORGET fnc3",
"Should refuse to forget a word defined before FENCE", TEST_ERROR_CASE, 1, 1, {0}
},
{
"forget_latest_keeps_predecessor",
"CREATE fnc5 FENCE CREATE fnc6 CREATE fnc7 FORGET fnc7 fnc6 DROP",
"Forgetting the newest word must not disturb an older one still above FENCE",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"IMMEDIATE", {
{"basic", ": test3 42 ; IMMEDIATE test3 . CR", "Should execute immediately", TEST_NORMAL, 0, 1, {0}},
{
"already_immediate", ": test4 43 ; IMMEDIATE IMMEDIATE", "Should handle double immediate", TEST_NORMAL, 0, 1, {0}
},
/* TODO: IMMEDIATE outside definition - requires compile-state tracking in IMMEDIATE */
/* {"outside_def", "IMMEDIATE", "Should error outside definition", TEST_ERROR_CASE, 1, 1}, */
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"FIND", {
{"existing", "FIND DUP . CR", "Should find system word", TEST_NORMAL, 0, 1, {0}},
{"user_word", ": test5 44 ; FIND test5 . CR", "Should find user word", TEST_NORMAL, 0, 1, {0}},
{"nonexistent", "FIND nonexistent . CR", "Should return 0", TEST_NORMAL, 0, 1, {0}},
{"empty", "FIND", "Should error (no token)", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"DEFINITIONS", {
{"basic", "FORTH DEFINITIONS", "Should set current to context", TEST_NORMAL, 0, 1, {0}},
{"multiple", "FORTH DEFINITIONS DEFINITIONS", "Should be idempotent", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"SMUDGE", {
{"during_def", ": test6 SMUDGE 45 ;", "Should hide incomplete def", TEST_NORMAL, 0, 1, {0}},
{"outside_def", "SMUDGE", "Should error outside def", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"LATEST", {
{"basic", "LATEST @ . CR", "Should show latest word", TEST_NORMAL, 0, 1, {0}},
{"after_def", ": test7 46 ; LATEST @ . CR", "Should update after def", TEST_NORMAL, 0, 1, {0}},
{
"after_forget", "CREATE test8 FORGET test8 LATEST @ . CR", "Should update after forget", TEST_NORMAL, 0,
1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
">BODY", {
{"basic", "CREATE test9 ' test9 >BODY . CR", "Should get param field", TEST_NORMAL, 0, 1, {0}},
{"variable", "VARIABLE var1 ' var1 >BODY . CR", "Should get var storage", TEST_NORMAL, 0, 1, {0}},
{"nonexistent", "' NONEXISTENT >BODY", "Should handle missing word", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"HIDDEN", {
{"basic", ": test10 HIDDEN 47 ;", "Should hide word", TEST_NORMAL, 0, 1, {0}},
{"outside_def", "HIDDEN", "Should error outside def", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all dictionary manipulation words test suites
* @param vm Pointer to the Forth virtual machine instance
* @details Runs through all test cases for CREATE, FORGET, IMMEDIATE, FIND,
* DEFINITIONS, SMUDGE, LATEST, >BODY, and HIDDEN words
*/
void run_dictionary_manipulation_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Dictionary Manipulation Words Tests (Module 14)...");
for (int i = 0; dict_manip_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &dict_manip_word_suites[i]);
}
print_module_summary("Dictionary Manipulation Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/dictionary_words_test.c
+216
View File
@@ -0,0 +1,216 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/* Dictionary Words Test Suites - Module 4 */
static WordTestSuite dictionary_word_suites[] = {
{
"HERE", {
{"basic", "HERE HERE = . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"after_comma", "HERE 42 , HERE SWAP - 1 CELLS = 0 SWAP /", "Asserts HERE advances by exactly 1 CELLS (8 bytes on 64-bit)", TEST_NORMAL, 0, 1, {0}},
{"after_c_comma", "HERE 65 C, HERE SWAP - . CR", "Should print: 1", TEST_NORMAL, 0, 1, {0}},
{"after_allot", "HERE 10 ALLOT HERE SWAP - . CR", "Should print: 10", TEST_NORMAL, 0, 1, {0}},
{"stability", "HERE DUP HERE = . CR", "Should be stable", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"ALLOT", {
{"basic", "HERE 10 ALLOT HERE SWAP - . CR", "Should print: 10", TEST_NORMAL, 0, 1, {0}},
{"zero", "HERE 0 ALLOT HERE SWAP - . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "HERE -4 ALLOT HERE SWAP - . CR", "Should print: -4", TEST_NORMAL, 0, 1, {0}},
{"large", "HERE 100 ALLOT HERE SWAP - . CR", "Should print: 100", TEST_NORMAL, 0, 1, {0}},
{"after_use", "ALIGN HERE 10 ALLOT 42 OVER ! @ . CR", "Should store and retrieve", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "ALLOT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
",", {
{"basic", "42 , HERE 1 CELLS - @ . CR", "Should compile 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-999 , HERE 1 CELLS - @ . CR", "Should compile -999", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 , HERE 1 CELLS - @ . CR", "Should compile 0", TEST_NORMAL, 0, 1, {0}},
{"max_int", "2147483647 , HERE 1 CELLS - @ . CR", "Should compile max int", TEST_EDGE_CASE, 0, 1, {0}},
{"min_int", "-2147483648 , HERE 1 CELLS - @ . CR", "Should compile min int", TEST_EDGE_CASE, 0, 1, {0}},
{"multiple", "10 , 20 , HERE 1 CELLS - @ . HERE 1 CELLS - @ . CR", "Should compile multiple", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", ",", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"C,", {
{"basic", "65 C, HERE 1 - C@ . CR", "Should compile byte 65", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 C, HERE 1 - C@ . CR", "Should compile byte 0", TEST_NORMAL, 0, 1, {0}},
{"high_byte", "255 C, HERE 1 - C@ . CR", "Should compile byte 255", TEST_NORMAL, 0, 1, {0}},
{"truncation", "256 C, HERE 1 - C@ . CR", "Should truncate to 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 C, HERE 1 - C@ . CR", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{"multiple", "65 C, 66 C, HERE 2 - C@ . HERE 1 - C@ . CR", "Should compile multiple", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "C,", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"2,", {
{"basic", "12345 67890 2, HERE 2 CELLS - 2@ . . CR", "Should compile double", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 0 2, HERE 2 CELLS - 2@ . . CR", "Should compile zero double", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1000 -2000 2, HERE 2 CELLS - 2@ . . CR", "Should compile negative double", TEST_NORMAL, 0, 1, {0}},
{"large", "2147483647 -1 2, HERE 2 CELLS - 2@ . . CR", "Should compile large double", TEST_EDGE_CASE, 0, 1, {0}},
{"one_item", "42 2,", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "2,", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"PAD", {
{"basic", "PAD PAD = . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"different_from_here", "PAD HERE = . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"stability", "PAD DUP PAD = . CR", "Should be stable", TEST_NORMAL, 0, 1, {0}},
{"usable", "PAD 42 OVER ! @ . CR", "Should be usable memory", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"SP@", {
// DISABLED: flaky on some architectures, non-deterministic
{"basic", "SP@ SP@ = . CR", "Should print: 0 (different after push)", TEST_NORMAL, 0, 0, {0}},
{"depth_effect", "42 SP@ SWAP DROP SP@ = . CR", "Should show stack effect", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "DEPTH 0= SP@ AND . CR", "Should work on empty stack", TEST_NORMAL, 0, 1, {0}},
{
"multiple_items", "1 2 3 SP@ SWAP DROP SWAP DROP SWAP DROP SP@ = . CR", "Should track changes",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"SP!", {
{"basic_restore", "1 2 3 SP@ 4 5 6 DROP DROP DROP SP! DEPTH .", "Should restore stack", TEST_NORMAL, 0, 1, {0}},
{"invalid_addr", "0 SP!", "Should cause error", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "SP!", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"LATEST", {
{"basic", "LATEST LATEST = . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"stability", "LATEST DUP LATEST = . CR", "Should be stable", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"COMPILATION", {
{
"here_comma_sequence", "HERE 10 , 20 , 30 , HERE SWAP - 12 = . CR", "Should advance HERE by 12",
TEST_NORMAL, 0, 1, {0}
},
{
"mixed_compilation", "HERE 42 , 65 C, 100 200 2, HERE SWAP - 13 = . CR", "Should advance correctly",
TEST_NORMAL, 0, 1, {0}
}, // MAY FAIL on non-4-byte platforms
{
"allot_comma_combo", "HERE 10 ALLOT 99 , HERE SWAP - 14 = . CR", "Should combine allot and comma",
TEST_NORMAL, 0, 1, {0}
},
{"pad_isolation", "PAD 999 OVER ! HERE 42 , PAD @ 999 = . CR", "PAD should be isolated", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"STACK_MGMT", {
{"sp_round_trip", "42 43 SP@ >R 44 45 R> SP! . . CR", "Should print: 43 42", TEST_NORMAL, 0, 1, {0}},
{
"depth_preservation", "1 2 3 DEPTH >R SP@ >R 4 5 6 R> SP! R> DEPTH = . CR", "Should preserve depth",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all dictionary word test suites
*
* @param vm Pointer to the FORTH virtual machine instance
*
* This function runs through all dictionary word test suites, including tests for:
* - HERE (dictionary pointer)
* - ALLOT (memory allocation)
* - Comma operations (, C, 2,)
* - PAD (scratch pad area)
* - Stack pointer operations (SP@ SP!)
* - LATEST (most recent dictionary entry)
* - Compilation sequences
* - Stack management operations
*/
void run_dictionary_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Dictionary Words Tests (Module 4)...");
for (int i = 0; dictionary_word_suites[i].word_name != NULL; i++) {
run_test_suite(vm, &dictionary_word_suites[i]);
}
print_module_summary("Dictionary Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/double_words_test.c
+346
View File
@@ -0,0 +1,346 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/* Double Number Words Test Suites - Module 6 */
static WordTestSuite double_word_suites[] = {
{
"2DROP", {
{"basic", "1 2 3 4 2DROP . . CR", "Should print: 1 2", TEST_NORMAL, 0, 1, {0}},
{"zeros", "0 0 42 99 2DROP . . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 -2 100 200 2DROP . . CR", "Should print: -1 -2", TEST_NORMAL, 0, 1, {0}},
{"exact_four", "10 20 30 40 2DROP DEPTH . CR", "Should print: 2", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "2DROP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 2DROP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"2DUP", {
{"basic", "100 200 2DUP . . . . CR", "Should print: 100 200 100 200", TEST_NORMAL, 0, 1, {0}},
{"zeros", "0 0 2DUP . . . . CR", "Should print: 0 0 0 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-100 -200 2DUP . . . . CR", "Should duplicate negatives", TEST_NORMAL, 0, 1, {0}},
{"depth_check", "10 20 2DUP DEPTH . CR", "Should print: 4", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "2DUP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 2DUP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"2OVER", {
{"basic", "10 20 30 40 2OVER . . . . . . CR", "Should print: 10 20 30 40 10 20", TEST_NORMAL, 0, 1, {0}},
{"zeros", "0 0 99 88 2OVER . . . . . . CR", "Should print: 0 0 99 88 0 0", TEST_NORMAL, 0, 1, {0}},
{"mixed", "-1 2 -3 4 2OVER . . . . . . CR", "Should handle mixed signs", TEST_NORMAL, 0, 1, {0}},
{"depth_check", "1 2 3 4 2OVER DEPTH . CR", "Should print: 6", TEST_NORMAL, 0, 1, {0}},
{"three_items", "1 2 3 2OVER", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "2OVER", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"2SWAP", {
{"basic", "10 20 30 40 2SWAP . . . . CR", "Should print: 30 40 10 20", TEST_NORMAL, 0, 1, {0}},
{"zeros", "0 0 99 88 2SWAP . . . . CR", "Should print: 99 88 0 0", TEST_NORMAL, 0, 1, {0}},
{"same_pairs", "42 42 42 42 2SWAP . . . . CR", "Should print: 42 42 42 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-10 -20 30 40 2SWAP . . . . CR", "Should print: 30 40 -10 -20", TEST_NORMAL, 0, 1, {0}},
{"depth_check", "1 2 3 4 2SWAP DEPTH . CR", "Should print: 4", TEST_NORMAL, 0, 1, {0}},
{"three_items", "1 2 3 2SWAP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "2SWAP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"2ROT", {
{"basic", "10 20 30 40 50 60 2ROT . . . . . . CR", "Should print: 30 40 50 60 10 20", TEST_NORMAL, 0, 1, {0}},
{"zeros", "0 0 1 1 2 2 2ROT . . . . . . CR", "Should rotate with zeros", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 -2 3 4 -5 -6 2ROT . . . . . . CR", "Should handle negatives", TEST_NORMAL, 0, 1, {0}},
{"depth_check", "1 2 3 4 5 6 2ROT DEPTH . CR", "Should print: 6", TEST_NORMAL, 0, 1, {0}},
{"five_items", "1 2 3 4 5 2ROT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "2ROT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"D+", {
{"basic", "100 200 300 400 D+ . . CR", "Should print: 400 600", TEST_NORMAL, 0, 1, {0}},
{"zero_add", "42 99 0 0 D+ . . CR", "Should print: 42 99", TEST_NORMAL, 0, 1, {0}},
{"negative", "-100 -200 50 75 D+ . . CR", "Should handle negatives", TEST_NORMAL, 0, 1, {0}},
{"carry", "2147483647 0 1 0 D+ . . CR", "Should handle carry", TEST_EDGE_CASE, 0, 1, {0}},
{"both_negative", "-100 -200 -300 -400 D+ . . CR", "Should add negatives", TEST_NORMAL, 0, 1, {0}},
{"three_items", "1 2 3 D+", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "D+", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"D-", {
{"basic", "500 600 100 200 D- . . CR", "Should print: 400 400", TEST_NORMAL, 0, 1, {0}},
{"zero_sub", "42 99 0 0 D- . . CR", "Should print: 42 99", TEST_NORMAL, 0, 1, {0}},
{"from_zero", "0 0 100 200 D- . . CR", "Should print: -100 -200", TEST_NORMAL, 0, 1, {0}},
{"negative", "100 200 -50 -75 D- . . CR", "Should handle negatives", TEST_NORMAL, 0, 1, {0}},
{"borrow", "0 0 1 0 D- . . CR", "Should handle borrow", TEST_EDGE_CASE, 0, 1, {0}},
{"same_values", "100 200 100 200 D- . . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"three_items", "1 2 3 D-", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "D-", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
8, {0}
},
{
"DNEGATE", {
{"positive", "100 200 DNEGATE . . CR", "Should negate positive double", TEST_NORMAL, 0, 1, {0}},
{"negative", "-100 -200 DNEGATE . . CR", "Should negate negative double", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 0 DNEGATE . . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"max_positive", "2147483647 0 DNEGATE . . CR", "Should negate max positive", TEST_EDGE_CASE, 0, 1, {0}},
{"one_item", "42 DNEGATE", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "DNEGATE", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"DABS", {
{"positive", "100 200 DABS . . CR", "Should print: 100 200", TEST_NORMAL, 0, 1, {0}},
{"negative", "-100 -200 DABS . . CR", "Should print: 100 200", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 0 DABS . . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"mixed_sign", "100 -1 DABS . . CR", "Should handle mixed sign", TEST_NORMAL, 0, 1, {0}},
{"min_double", "-2147483648 -1 DABS . . CR", "Should handle min double", TEST_EDGE_CASE, 0, 1, {0}},
{"one_item", "42 DABS", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "DABS", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"DMIN", {
{"basic", "100 200 300 400 DMIN . . CR", "Should print: 100 200", TEST_NORMAL, 0, 1, {0}},
{"equal", "42 99 42 99 DMIN . . CR", "Should print: 42 99", TEST_NORMAL, 0, 1, {0}},
{"negative", "-100 -200 -50 -75 DMIN . . CR", "Should find min negative", TEST_NORMAL, 0, 1, {0}},
{"mixed", "-100 -1 100 0 DMIN . . CR", "Should handle mixed signs", TEST_NORMAL, 0, 1, {0}},
{"three_items", "1 2 3 DMIN", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "DMIN", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"DMAX", {
{"basic", "100 200 300 400 DMAX . . CR", "Should print: 300 400", TEST_NORMAL, 0, 1, {0}},
{"equal", "42 99 42 99 DMAX . . CR", "Should print: 42 99", TEST_NORMAL, 0, 1, {0}},
{"negative", "-300 -400 -100 -200 DMAX . . CR", "Should find max negative", TEST_NORMAL, 0, 1, {0}},
{"mixed", "-100 -1 100 0 DMAX . . CR", "Should handle mixed signs", TEST_NORMAL, 0, 1, {0}},
{"three_items", "1 2 3 DMAX", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "DMAX", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"D=", {
{"equal", "100 200 100 200 D= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"not_equal_low", "100 200 101 200 D= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"not_equal_high", "100 200 100 201 D= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"zero_equal", "0 0 0 0 D= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"negative_equal", "-100 -200 -100 -200 D= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"three_items", "1 2 3 D=", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "D=", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"D<", {
{"less_than", "100 200 300 400 D< . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"greater_than", "300 400 100 200 D< . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"equal", "100 200 100 200 D< . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative_positive", "-100 -1 100 0 D< . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"negative_negative", "-300 -1 -100 -1 D< . CR", "Should compare negatives", TEST_NORMAL, 0, 1, {0}},
{"high_word_diff", "100 200 100 300 D< . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"three_items", "1 2 3 D<", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "D<", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
8, {0}
},
{
"D0=", {
{"zero", "0 0 D0= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"positive", "100 200 D0= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-100 -200 D0= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"zero_high", "0 100 D0= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"zero_low", "100 0 D0= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"one_item", "42 D0=", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "D0=", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"D0<", {
{"negative", "-100 -1 D0< . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 0 D0< . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"positive", "100 0 D0< . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative_high_only", "100 -1 D0< . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"large_negative", "-1 -1 D0< . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"one_item", "42 D0<", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "D0<", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"S>D", {
{"positive", "5 S>D . . CR", "Should sign-extend positive: 0 5", TEST_NORMAL, 0, 1, {0}},
{"negative", "-5 S>D . . CR", "Should sign-extend negative: -1 -5", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 S>D . . CR", "Should sign-extend zero: 0 0", TEST_NORMAL, 0, 1, {0}},
{"max_int", "2147483647 S>D . . CR", "Should extend max int: 0 2147483647", TEST_EDGE_CASE, 0, 1, {0}},
{"min_int", "-2147483648 S>D . . CR","Should extend min int: -1 -2147483648", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "S>D", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"D2*", {
{"basic", "5 0 D2* . . CR", "Should double 5: 0 10", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 0 D2* . . CR", "Should double zero: 0 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 -1 D2* . . CR", "Should double -1: -1 -2", TEST_NORMAL, 0, 1, {0}},
{"carry", "0 1 D2* . . CR", "Should shift high cell: 0 2", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "D2*", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"D2/", {
{"basic", "10 0 D2/ . . CR", "Should halve 10: 0 5", TEST_NORMAL, 0, 1, {0}},
{"negative", "-2 -1 D2/ . . CR", "Should halve -2: -1 -1", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 0 D2/ . . CR", "Should halve zero: 0 0", TEST_NORMAL, 0, 1, {0}},
{"odd", "3 0 D2/ . . CR", "Should truncate toward zero: 0 1", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "D2/", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
/* NOTE: 2>R/2R>/2R@ are tested at REPL level (not inside compiled words).
* The execution loop stores the IP in return_stack[rsp]; if 2>R were called
* inside a colon definition, it would increment rsp and the loop would
* dereference the pushed data value as a pointer — same model as >R tests. */
"2>R", {
{"roundtrip", "10 20 2>R 2R> . . CR", "Should store and retrieve: 20 10", TEST_NORMAL, 0, 1, {0}},
{"depth_after", "1 2 2>R DEPTH . 2R> DROP DROP CR", "Should empty data stack: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "2>R", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"2R>", {
{"roundtrip", "5 6 2>R 2R> . . CR", "Should retrieve double: 6 5", TEST_NORMAL, 0, 1, {0}},
{"depth", "9 8 2>R 2R> DEPTH . CR", "Should push 2 items to data stack: 2", TEST_NORMAL, 0, 1, {0}},
{"empty_rstack","2R>", "Should cause return stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"2R@", {
{"peek", "3 4 2>R 2R@ . . 2R> DROP DROP CR", "Should peek: 4 3", TEST_NORMAL, 0, 1, {0}},
{"non_destructive", "7 8 2>R 2R@ DROP DROP 2R> . . CR", "Should leave rstack intact", TEST_NORMAL, 0, 1, {0}},
{"empty_rstack", "2R@", "Should cause return stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all test suites for double number words
*
* This function runs comprehensive tests for all double number word operations,
* including stack manipulation (2DROP, 2DUP, etc.), arithmetic operations (D+, D-, etc.),
* and comparison operations (D=, D<, etc.).
*
* @param vm Pointer to the virtual machine instance where tests will be executed
*/
void run_double_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Double Number Words Tests (Module 6)...");
for (int i = 0; double_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &double_word_suites[i]);
}
print_module_summary("Double Number Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/format_words_test.c
+170
View File
@@ -0,0 +1,170 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/**
* @brief Test suites for format words (Module 10)
* Contains test cases for number base conversion and formatting operations
*/
static WordTestSuite format_word_suites[] = {
{
"BASE", {
{"decimal", "DECIMAL 42 . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"hex", "HEX FF . CR", "Should print: FF", TEST_NORMAL, 0, 1, {0}},
{"octal", "OCTAL 52 . CR", "Should print: 52", TEST_NORMAL, 0, 1, {0}},
{"base_store", "16 BASE ! 255 . CR", "Should print: FF", TEST_NORMAL, 0, 1, {0}},
{"base_fetch", "BASE @ . CR", "Should print current base", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"DECIMAL", {
{"from_hex", "HEX FF DECIMAL . CR", "Should print: 255", TEST_NORMAL, 0, 1, {0}},
{"from_octal", "OCTAL 52 DECIMAL . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"state_persist", "DECIMAL 42 . CR 42 . CR HEX 42 . CR", "Should maintain base", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"HEX", {
{"from_decimal", "DECIMAL 255 HEX . CR", "Should print: FF", TEST_NORMAL, 0, 1, {0}},
{"from_octal", "OCTAL 52 HEX . CR", "Should print: 2A", TEST_NORMAL, 0, 1, {0}},
{"state_persist", "HEX FF . CR DECIMAL 255 . CR", "Should maintain base", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"OCTAL", {
{"from_decimal", "DECIMAL 42 OCTAL . CR", "Should print: 52", TEST_NORMAL, 0, 1, {0}},
{"from_hex", "HEX 2A OCTAL . CR", "Should print: 52", TEST_NORMAL, 0, 1, {0}},
{"state_persist", "DECIMAL 42 . CR OCTAL 52 . CR", "Should maintain base", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"<#", {
{"basic", "DECIMAL 42 S>D <# #S #> TYPE CR", "Should format number", TEST_NORMAL, 0, 1, {0}},
{"empty", "0 <# #> TYPE CR", "Should handle zero", TEST_NORMAL, 0, 1, {0}},
{"negative", "-42 <# #S #> TYPE CR", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"#", {
{"single_digit", "15 <# # #> TYPE CR", "Should print rightmost digit", TEST_NORMAL, 0, 1, {0}},
{"multiple", "15 <# # # #> TYPE CR", "Should print digits right to left", TEST_NORMAL, 0, 1, {0}},
{"zero_pad", "5 <# # 0 # #> TYPE CR", "Should handle zero padding", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"#S", {
{"basic", "42 <# #S #> TYPE CR", "Should convert all digits", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 <# #S #> TYPE CR", "Should handle zero", TEST_NORMAL, 0, 1, {0}},
{"large", "1234567890 <# #S #> TYPE CR", "Should handle large numbers", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"SIGN", {
{"negative", "-42 ABS <# #S SIGN #> TYPE CR", "Should add minus", TEST_NORMAL, 0, 1, {0}},
{"positive", "42 <# #S SIGN #> TYPE CR", "Should not add sign", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 <# #S SIGN #> TYPE CR", "Should handle zero", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"#>", {
{"normal", "42 <# #S #> TYPE CR", "Should terminate formatting", TEST_NORMAL, 0, 1, {0}},
{"empty", "0 <# #> TYPE CR", "Should handle empty format", TEST_NORMAL, 0, 1, {0}},
{"stack_effect", "42 <# #S #> SWAP . . CR", "Should leave addr u", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"HOLD", {
{"basic", "42 <# 46 HOLD #S #> TYPE CR", "Should insert dot", TEST_NORMAL, 0, 1, {0}},
{"overflow", "<# 257 HOLD #>", "Should handle overflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all format words test suites
* @param vm Pointer to the Forth virtual machine instance
* @details Runs through all test cases for number base manipulation and formatting words
*/
void run_format_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Format Words Tests (Module 10)...");
for (int i = 0; format_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &format_word_suites[i]);
}
print_module_summary("Format Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/inference_words_test.c
+139
View File
@@ -0,0 +1,139 @@
/*
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.
*/
/*
* inference_words_test.c — POST tests for the SSM inference engine's
* proof-covered accessor/primitive words (Module 26)
*
* inference_words.c registers 20 words; only 8 are proof-covered per
* proof/COVERAGE.md ("5 accessors full; rest guard/shape") — this file
* covers exactly those 8, not the L8 Jacquard / Bayesian-posterior words,
* which COVERAGE.md does not claim coverage for. No test file existed for
* any word in this module before.
*
* The three array-based primitives (Q.VARIANCE/INFER-DECAY-SLOPE/
* INFER-WINDOW-WIDTH) need real data in VM memory — HERE is used as
* scratch, matching the idiom memory_words_test.c already uses. The four
* *-@ accessors and INFER-RUN are exercised in one suite (INFER-WINDOW@)
* that runs INFER-RUN first, since the accessors just read
* vm->last_inference_outputs and INFER-RUN is what populates it.
*/
#include "../include/test_runner.h"
#include "../include/test_common.h"
/* Inference Engine Words Test Suites - Module 26 */
static WordTestSuite inference_word_suites[] = {
{
"Q.VARIANCE", {
{"three_cells", "100 HERE ! 200 HERE 8 + ! 300 HERE 16 + ! HERE 3 Q.VARIANCE Q.TO-INT . CR",
"Should print population variance of {100,200,300} (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"INFER-DECAY-SLOPE", {
{"three_cells", "300 HERE ! 200 HERE 8 + ! 100 HERE 16 + ! HERE 3 INFER-DECAY-SLOPE Q.TO-INT . CR",
"Should print decay slope for a decreasing trajectory (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"INFER-WINDOW-WIDTH", {
{"three_cells", "100 HERE ! 200 HERE 8 + ! 300 HERE 16 + ! HERE 3 INFER-WINDOW-WIDTH . CR",
"Should print an inferred window width (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"INFER-RUN", {
{"basic", "INFER-RUN", "Should run without error", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"INFER-WINDOW@", {
{"after_run", "INFER-RUN INFER-WINDOW@ . CR", "Should print last adaptive_window_width (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"INFER-DECAY@", {
{"after_run", "INFER-RUN INFER-DECAY@ Q.TO-INT . CR", "Should print last adaptive_decay_slope (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"INFER-VARIANCE@", {
{"after_run", "INFER-RUN INFER-VARIANCE@ Q.TO-INT . CR", "Should print last window_variance_q48 (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"INFER-FIT@", {
{"after_run", "INFER-RUN INFER-FIT@ Q.TO-INT . CR", "Should print last slope_fit_quality_q48 (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"INFER-EARLY-EXIT@", {
{"after_run", "INFER-RUN INFER-EARLY-EXIT@ . CR", "Should print 0 or 1 (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes the proof-covered subset of inference-engine word test suites
* @param vm Pointer to the Forth virtual machine instance
* @details Covers the 8 words proof/COVERAGE.md marks as proof-covered in
* inference_words.c: the three array-based primitives (Q.VARIANCE,
* INFER-DECAY-SLOPE, INFER-WINDOW-WIDTH), INFER-RUN, and the four
* *-@ output accessors (INFER-WINDOW@/DECAY@/VARIANCE@/FIT@) plus
* INFER-EARLY-EXIT@. Does not cover the L8 Jacquard or Bayesian
* posterior words in the same file — not claimed as proof-covered.
*/
void run_inference_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Inference Engine Words Tests (Module 26)...");
/* CONTRACT_NONE, not CONTRACT_PHYSICS_TRANSPARENT: these words read
* physics state (rolling window, dictionary heat) by design -- A4'
* transparency is a property they deliberately do not have. */
WordContract mod = {CONTRACT_NONE, 0};
for (int i = 0; inference_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite_m(vm, &inference_word_suites[i], mod);
}
print_module_summary("Inference Engine Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/integration_tests.c
+233
View File
@@ -0,0 +1,233 @@
/*
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.
*/
/**
* @file integration_tests.c
* @brief Full program integration tests for StarForth
*
* This file contains integration tests that verify complete Forth programs
* as regression tests. It includes test suites for complete programs,
* data structures, and algorithms implementations.
*/
#include "test_common.h"
#include "test_runner.h"
/* Integration test suites - complete Forth programs */
static WordTestSuite integration_suites[] = {
{
"COMPLETE_PROGRAMS", {
{
"prime_check",
": PRIME? ( n -- flag ) "
" DUP 2 < IF DROP 0 EXIT THEN "
" DUP 2 = IF DROP -1 EXIT THEN "
" DUP 2 MOD 0= IF DROP 0 EXIT THEN "
" DUP 3 DO "
" DUP I MOD 0= IF DROP 0 EXIT THEN "
" 2 +LOOP "
" DROP -1 "
"; "
"17 PRIME? . CR",
"Prime number checker",
TEST_NORMAL, 0, 1, {0}
},
{
"array_sum",
": ARRAY 5 CELLS ALLOT ; "
"ARRAY NUMS "
": STORE-NUMS "
" 10 NUMS 0 CELLS + ! "
" 20 NUMS 1 CELLS + ! "
" 30 NUMS 2 CELLS + ! "
" 40 NUMS 3 CELLS + ! "
" 50 NUMS 4 CELLS + ! "
"; "
": SUM-NUMS "
" 0 5 0 DO "
" NUMS I CELLS + @ + "
" LOOP "
"; "
"STORE-NUMS SUM-NUMS . CR",
"Array sum program",
TEST_NORMAL, 0, 1, {0}
},
{
"fizzbuzz_mini",
": FIZZ? 3 MOD 0= ; "
": BUZZ? 5 MOD 0= ; "
": FIZZBUZZ "
" DUP FIZZ? OVER BUZZ? AND IF DROP .\" FizzBuzz \" EXIT THEN "
" DUP FIZZ? IF DROP .\" Fizz \" EXIT THEN "
" DUP BUZZ? IF DROP .\" Buzz \" EXIT THEN "
" . "
"; "
"15 FIZZBUZZ CR",
"FizzBuzz for 15",
TEST_NORMAL, 0, 1, {0}
},
{
"calculator",
": + DEPTH 2 < IF .\" Stack underflow\" CR EXIT THEN + ; "
": CALC "
" 5 3 + "
" 2 * "
" 4 - "
" . CR "
"; "
"CALC",
"Simple calculator",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"DATA_STRUCTURES", {
{
"linked_list",
"VARIABLE HEAD "
"0 HEAD ! "
": NODE ( value -- addr ) "
" HERE "
" , " /* value */
" HEAD @ , " /* next pointer */
" DUP HEAD ! "
"; "
": PRINT-LIST ( -- ) "
" HEAD @ "
" BEGIN DUP WHILE "
" DUP @ . "
" CELL+ @ "
" REPEAT DROP CR "
"; "
"10 NODE DROP "
"20 NODE DROP "
"30 NODE DROP "
"PRINT-LIST",
"Simple linked list",
TEST_NORMAL, 0, 1, {0}
},
{
"stack_min_max",
": INIT-MINMAX "
" 2147483647 VARIABLE MIN " /* Max int */
" -2147483648 VARIABLE MAX " /* Min int */
"; "
": UPDATE-MINMAX ( n -- ) "
" DUP MIN @ < IF DUP MIN ! ELSE DROP THEN "
" DUP MAX @ > IF DUP MAX ! ELSE DROP THEN "
"; "
"INIT-MINMAX "
"42 UPDATE-MINMAX "
"17 UPDATE-MINMAX "
"99 UPDATE-MINMAX "
"MIN @ . MAX @ . CR",
"Min/Max tracker",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"ALGORITHMS", {
{
"bubble_sort_concept",
": SWAP-IF-NEEDED ( addr1 addr2 -- ) "
" OVER @ OVER @ > IF "
" OVER @ OVER @ "
" ROT ! SWAP ! "
" ELSE 2DROP THEN "
"; "
"VARIABLE A "
"VARIABLE B "
"5 A ! 3 B ! "
"A B SWAP-IF-NEEDED "
"A @ . B @ . CR",
"Swap if needed (sort helper)",
TEST_NORMAL, 0, 1, {0}
},
{
"gcd",
": GCD ( a b -- gcd ) "
" BEGIN DUP WHILE "
" TUCK MOD "
" REPEAT DROP "
"; "
"48 18 GCD . CR",
"Greatest Common Divisor",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
};
/**
* @brief Executes all integration test suites for StarForth
*
* @param vm Pointer to the Forth virtual machine instance
*
* This function runs through all defined integration test suites, including:
* - Complete Programs suite (prime checker, array operations, etc)
* - Data Structures suite (linked list, min/max tracker)
* - Algorithms suite (sorting, GCD)
*/
void run_integration_tests(VM *vm) {
if (!vm) return;
log_message(LOG_INFO, "==============================================");
log_message(LOG_INFO, " StarForth Integration Test Suite");
log_message(LOG_INFO, " Complete Forth Programs");
log_message(LOG_INFO, "==============================================\n");
for (size_t i = 0; i < sizeof(integration_suites) / sizeof(WordTestSuite); i++) {
run_test_suite(vm, &integration_suites[i]);
}
log_message(LOG_INFO, "\n==============================================");
log_message(LOG_INFO, " Integration Tests Complete");
log_message(LOG_INFO, "==============================================\n");
}
v3/src/test_runner/modules/io_words_test.c
+285
View File
@@ -0,0 +1,285 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/**
* @brief Test suites for I/O words (Module 9)
* @details Contains comprehensive test cases for all I/O related FORTH words
* including output formatting, character I/O, and base conversion operations
*/
static WordTestSuite io_word_suites[] = {
{
".", {
{"positive", "42 . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-42 . CR", "Should print: -42", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"max_int", "2147483647 . CR", "Should print: 2147483647", TEST_EDGE_CASE, 0, 1, {0}},
{"min_int", "-2147483648 . CR", "Should print: -2147483648", TEST_EDGE_CASE, 0, 1, {0}},
{"multiple", "1 2 3 . . . CR", "Should print: 3 2 1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", ".", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"CR", {
{"basic", "42 . CR 43 . CR", "Should print on separate lines", TEST_NORMAL, 0, 1, {0}},
{"multiple", "CR CR CR", "Should print multiple newlines", TEST_NORMAL, 0, 1, {0}},
{"no_stack_effect", "DEPTH CR DEPTH = . CR", "Should not affect stack", TEST_NORMAL, 0, 1, {0}},
{"after_output", "1 2 3 . . . CR", "Should work after output", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"SPACE", {
{"basic", "42 . SPACE 43 . CR", "Should add space between numbers", TEST_NORMAL, 0, 1, {0}},
{"multiple", "SPACE SPACE SPACE", "Should print multiple spaces", TEST_NORMAL, 0, 1, {0}},
{"no_stack_effect", "DEPTH SPACE DEPTH = . CR", "Should not affect stack", TEST_NORMAL, 0, 1, {0}},
{"with_text", "65 EMIT SPACE 66 EMIT CR", "Should space between chars", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"SPACES", {
{"zero", "0 SPACES", "Should print no spaces", TEST_NORMAL, 0, 1, {0}},
{"one", "1 SPACES", "Should print one space", TEST_NORMAL, 0, 1, {0}},
{"multiple", "5 SPACES", "Should print five spaces", TEST_NORMAL, 0, 1, {0}},
{"large", "20 SPACES", "Should print twenty spaces", TEST_NORMAL, 0, 1, {0}},
{"negative", "-5 SPACES", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{"with_output", "42 . 3 SPACES 43 . CR", "Should space output", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "SPACES", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"EMIT", {
{"letter_A", "65 EMIT CR", "Should print: A", TEST_NORMAL, 0, 1, {0}},
{"letter_Z", "90 EMIT CR", "Should print: Z", TEST_NORMAL, 0, 1, {0}},
{"digit", "48 EMIT CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"space_char", "32 EMIT CR", "Should print space", TEST_NORMAL, 0, 1, {0}},
{"newline", "10 EMIT", "Should print newline", TEST_NORMAL, 0, 1, {0}},
{"high_ascii", "127 EMIT CR", "Should print DEL char", TEST_NORMAL, 0, 1, {0}},
{"truncation", "321 EMIT CR", "Should truncate to low byte", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 EMIT CR", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{"sequence", "72 EMIT 73 EMIT 10 EMIT", "Should print: HI", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "EMIT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
10, {0}
},
{
"KEY", {
{"basic_test", "KEY DROP", "Should wait for keypress", TEST_NORMAL, 0, 0, {0}},
{"echo_test", "KEY DUP EMIT CR", "Should echo keypresses", TEST_NORMAL, 0, 0, {0}},
{"multiple", "KEY KEY KEY DROP DROP DROP", "Should read multiple keys", TEST_NORMAL, 0, 0, {0}},
{"no_stack_underflow", "KEY . CR", "Should push key to stack", TEST_NORMAL, 0, 0, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"?KEY", {
{"available_test", "?KEY . CR", "Should test key availability", TEST_NORMAL, 0, 0, {0}},
{"no_wait", "?KEY IF KEY EMIT THEN CR", "Should not wait", TEST_NORMAL, 0, 0, {0}},
{"multiple_check", "?KEY ?KEY OR . CR", "Should check availability", TEST_NORMAL, 0, 0, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"TYPE", {
{
"basic_string", "HERE S\" Hello\" DUP >R HERE SWAP CMOVE HERE R> TYPE CR", "Should print: Hello",
TEST_NORMAL, 0, 1, {0}
},
{"empty_string", "HERE 0 TYPE CR", "Should print nothing", TEST_NORMAL, 0, 1, {0}},
{"single_char", "HERE 65 OVER C! 1 TYPE CR", "Should print: A", TEST_NORMAL, 0, 1, {0}},
{
"numbers", "HERE S\" 12345\" DUP >R HERE SWAP CMOVE HERE R> TYPE CR", "Should print: 12345",
TEST_NORMAL, 0, 1, {0}
},
{"zero_length", "PAD 0 TYPE", "Should handle zero length", TEST_NORMAL, 0, 1, {0}},
{"one_item", "PAD TYPE", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "TYPE", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"COUNT", {
{
"basic", "HERE S\" Test\" DROP C@ HERE 1+ SWAP COUNT . . CR", "Should show length and addr+1",
TEST_NORMAL, 0, 1, {0}
},
{"empty", "HERE 0 OVER C! COUNT . . CR", "Should handle empty string", TEST_NORMAL, 0, 1, {0}},
{"max_length", "HERE 255 OVER C! COUNT . . CR", "Should handle max length", TEST_NORMAL, 0, 1, {0}},
{"zero_addr_plus_one", "HERE COUNT SWAP 1- = . CR", "Should increment address", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "COUNT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"EXPECT", {
{"basic_input", "PAD 10 EXPECT", "Should read up to 10 chars", TEST_NORMAL, 0, 0, {0}},
{"max_length", "PAD 80 EXPECT", "Should read up to 80 chars", TEST_NORMAL, 0, 0, {0}},
{"zero_length", "PAD 0 EXPECT", "Should handle zero length", TEST_NORMAL, 0, 1, {0}},
{"one_item", "PAD EXPECT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "EXPECT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"SPAN", {
{"after_expect", "PAD 10 EXPECT SPAN @ . CR", "Should show chars read", TEST_NORMAL, 0, 0, {0}},
{"zero_input", "PAD 0 EXPECT SPAN @ . CR", "Should show zero", TEST_NORMAL, 0, 1, {0}},
{"variable_test", "SPAN @ SPAN @ = . CR", "Should be consistent", TEST_NORMAL, 0, 1, {0}},
{"address_test", "SPAN 0<> . CR", "Should be valid address", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"WORD", {
/* Basic functionality */
{"basic_parse", "BL WORD COUNT TYPE CR", "Should parse next word", TEST_NORMAL, 0, 0, {0}},
{"delimiter_test", "44 WORD COUNT TYPE CR", "Should use comma delimiter", TEST_NORMAL, 0, 0, {0}},
{"empty_input", "BL WORD COUNT . CR", "Should handle empty input", TEST_NORMAL, 0, 1, {0}},
/* Different delimiters */
{"space_delim", "32 WORD DROP", "Should use space as delimiter", TEST_NORMAL, 0, 1, {0}},
{"newline_delim", "10 WORD DROP", "Should use newline as delimiter", TEST_NORMAL, 0, 1, {0}},
{"tab_delim", "9 WORD DROP", "Should use tab as delimiter", TEST_NORMAL, 0, 1, {0}},
{"comma_delim", "44 WORD DROP", "Should use comma as delimiter", TEST_NORMAL, 0, 1, {0}},
/* Leading delimiters */
{"skip_leading", "BL WORD DROP", "Should skip leading spaces", TEST_NORMAL, 0, 1, {0}},
/* Word length tests */
{"single_char", "BL WORD COUNT . CR", "Should parse single character", TEST_NORMAL, 0, 1, {0}},
{"long_word", "BL WORD COUNT 0 > . CR", "Should parse long word", TEST_NORMAL, 0, 1, {0}},
/* Edge cases */
{"zero_delim", "0 WORD DROP", "Should handle null delimiter", TEST_NORMAL, 0, 1, {0}},
{"high_ascii", "127 WORD DROP", "Should handle DEL delimiter", TEST_NORMAL, 0, 1, {0}},
/* Count-prefixed string */
{"count_format", "BL WORD C@ . CR", "Should have count byte", TEST_NORMAL, 0, 1, {0}},
{"count_value", "BL WORD COUNT SWAP DROP . CR", "Should return count", TEST_NORMAL, 0, 1, {0}},
/* Error cases */
{"empty_stack", "WORD", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
/* Consecutive delimiters */
{"multi_delim", "BL WORD DROP BL WORD DROP", "Should handle multiple parses", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
17, {0}
},
/* Base conversion and formatting tests */
{
"BASE_OUTPUT", {
{"decimal", "10 BASE ! 255 . CR", "Should print: 255", TEST_NORMAL, 0, 1, {0}},
{"hex", "16 BASE ! 255 . CR", "Should print: FF", TEST_NORMAL, 0, 1, {0}},
{"octal", "8 BASE ! 64 . CR", "Should print: 100", TEST_NORMAL, 0, 1, {0}},
{"binary", "5 2 BASE ! . CR", "Should print: 101", TEST_NORMAL, 0, 1, {0}},
{
"base_restore", "BASE @ DECIMAL 255 16 BASE ! . BASE ! CR", "Should restore base", TEST_NORMAL, 0,
1, {0}
},
{"reset_decimal", "DECIMAL", "Reset base to DECIMAL for subsequent tests", TEST_NORMAL, 0, 0, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
/* Output formatting combinations */
{
"FORMAT_COMBO", {
{"number_space_number", "DECIMAL 42 . SPACE 43 . CR", "Should format: 42 43", TEST_NORMAL, 0, 1, {0}},
{"multi_line", "DECIMAL 1 . CR 2 . CR 3 . CR", "Should print on separate lines", TEST_NORMAL, 0, 1, {0}},
{"indented", "DECIMAL 5 SPACES 42 . CR", "Should indent number", TEST_NORMAL, 0, 1, {0}},
{"table_format", "DECIMAL 1 . 3 SPACES 10 . 3 SPACES 100 . CR", "Should format table", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all I/O words test suites
* @param vm Pointer to the FORTH virtual machine instance
* @details Runs through all defined test suites for I/O words, logging results_run_01_2025_12_08
* and providing a summary of the test execution
*/
void run_io_words_tests(VM *vm) {
log_message(LOG_INFO, "Running I/O Words Tests (Module 9)...");
for (int i = 0; io_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &io_word_suites[i]);
}
print_module_summary("I/O Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/logical_words_test.c
+306
View File
@@ -0,0 +1,306 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/* Logical Words Test Suites - Module 8 */
static WordTestSuite logical_word_suites[] = {
{
"AND", {
{"both_true", "-1 -1 AND . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"first_false", "0 -1 AND . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"second_false", "-1 0 AND . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"both_false", "0 0 AND . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"bitwise", "85 51 AND . CR", "Should print: 17", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "AND", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 AND", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"OR", {
{"both_true", "-1 -1 OR . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"first_false", "0 -1 OR . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"second_false", "-1 0 OR . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"both_false", "0 0 OR . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"bitwise", "85 51 OR . CR", "Should print: 119", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "OR", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 OR", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"XOR", {
{"both_true", "-1 -1 XOR . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"first_false", "0 -1 XOR . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"second_false", "-1 0 XOR . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"both_false", "0 0 XOR . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"bitwise", "85 51 XOR . CR", "Should print: 102", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "XOR", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 XOR", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"NOT", {
{"true", "-1 NOT . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"false", "0 NOT . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"positive", "42 NOT . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-42 NOT . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "NOT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"=", {
{"equal", "42 42 = . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"not_equal", "42 43 = . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"zero_equal", "0 0 = . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"negative_equal", "-42 -42 = . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"negative_positive", "-42 42 = . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "=", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 =", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"<>", {
{"not_equal", "42 43 <> . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"equal", "42 42 <> . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"zero_equal", "0 0 <> . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-42 42 <> . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "<>", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 <>", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"<", {
{"less_than", "5 7 < . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"greater_than", "7 5 < . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"equal", "5 5 < . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative_positive", "-5 5 < . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"negative_negative", "-7 -5 < . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "<", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 <", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
">", {
{"greater_than", "7 5 > . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"less_than", "5 7 > . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"equal", "5 5 > . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"positive_negative", "5 -5 > . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"negative_negative", "-5 -7 > . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", ">", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 >", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"0=", {
{"zero", "0 0= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"positive", "42 0= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-42 0= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "0=", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"0<", {
{"negative", "-42 0< . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 0< . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"positive", "42 0< . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "0<", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"0>", {
{"positive", "42 0> . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 0> . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-42 0> . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "0>", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"0<>", {
{"nonzero_pos", "42 0<> . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"nonzero_neg", "-1 0<> . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 0<> . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "0<>", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"U<", {
{"less", "3 5 U< . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"equal", "5 5 U< . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"greater", "7 5 U< . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"zero_one", "0 1 U< . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "U<", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"U>", {
{"greater", "5 3 U> . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"equal", "5 5 U> . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"less", "3 5 U> . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"one_zero", "1 0 U> . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "U>", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"WITHIN", {
{"in_range", "3 1 5 WITHIN . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"at_low", "1 1 5 WITHIN . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"at_high", "5 1 5 WITHIN . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"below", "0 1 5 WITHIN . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"above", "6 1 5 WITHIN . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "WITHIN", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"TRUE", {
{"value", "TRUE . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"as_flag", "TRUE 0= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"in_and", "TRUE TRUE AND . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"FALSE", {
{"value", "FALSE . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"as_flag", "FALSE 0= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"in_or", "TRUE FALSE OR . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
">=", {
{"less", "3 5 >= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"greater", "5 3 >= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"equal", "3 3 >= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 0 >= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"neg_neg", "-1 -2 >= . CR","Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"underflow", ">=", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"<=", {
{"less", "3 5 <= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"greater", "5 3 <= . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"equal", "3 3 <= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 0 <= . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"neg_neg", "-2 -1 <= . CR","Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"underflow", "<=", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all logical words test suites
*
* This function runs comprehensive tests for all FORTH logical and comparison operators,
* including stack underflow checks and edge cases.
*
* @param vm Pointer to the FORTH virtual machine instance
*/
void run_logical_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Logical Words Tests (Module 8)...");
WordContract mod = {CONTRACT_PHYSICS_TRANSPARENT, 0};
for (int i = 0; logical_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite_m(vm, &logical_word_suites[i], mod);
}
print_module_summary("Logical Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/mama_forth_words_test.c
+274
View File
@@ -0,0 +1,274 @@
/*
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.
*/
/**
* @file mama_forth_words_test.c
* @brief Test module for Mama FORTH vocabulary (M7.1 Capsule System)
*
* Tests for the MAMA vocabulary words. These words are kernel-only
* (__STARKERNEL__), so in hosted builds all tests are marked as
* not implemented and will be skipped.
*
* In kernel builds, these tests validate:
* - Capsule directory enumeration
* - Descriptor field access
* - VM birth protocol
* - Experiment execution
*/
#include "../include/test_runner.h"
#include "../include/test_common.h"
/*
* Mama FORTH words (CAPSULE-COUNT etc.) are kernel runtime objects, not
* FORTH dictionary words. They do not live in the StarForth dictionary,
* so there is nothing to test via vm_interpret. Mark all tests skipped.
*/
#define MAMA_IMPLEMENTED 0
/* Mama FORTH Words Test Suites */
static WordTestSuite mama_word_suites[] = {
{
"CAPSULE-COUNT",
{
{
"basic",
"CAPSULE-COUNT . CR",
"Should print number of capsules",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"non_negative",
"CAPSULE-COUNT 0 >= . CR",
"Should be >= 0",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"CAPSULE@",
{
{
"first_capsule",
"0 CAPSULE@ . CR",
"Should return first descriptor address",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"out_of_bounds",
"9999 CAPSULE@ . CR",
"Should return 0 for invalid index",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"empty_stack",
"CAPSULE@",
"Should cause stack underflow",
TEST_ERROR_CASE, 1, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"CAPSULE-FLAGS@",
{
{
"basic",
"0 CAPSULE@ CAPSULE-FLAGS@ . CR",
"Should return flags from descriptor",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"null_desc",
"0 CAPSULE-FLAGS@ . CR",
"Should handle null descriptor",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"empty_stack",
"CAPSULE-FLAGS@",
"Should cause stack underflow",
TEST_ERROR_CASE, 1, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"CAPSULE-LEN@",
{
{
"basic",
"0 CAPSULE@ CAPSULE-LEN@ . CR",
"Should return payload length",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"empty_stack",
"CAPSULE-LEN@",
"Should cause stack underflow",
TEST_ERROR_CASE, 1, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"CAPSULE-HASH@",
{
{
"basic",
"0 CAPSULE@ CAPSULE-HASH@ . CR",
"Should return content hash",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"empty_stack",
"CAPSULE-HASH@",
"Should cause stack underflow",
TEST_ERROR_CASE, 1, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"MAMA-VM-ID",
{
{
"always_zero",
"MAMA-VM-ID . CR",
"Should always print 0",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"equals_zero",
"MAMA-VM-ID 0 = . CR",
"Should equal 0",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"VM-COUNT",
{
{
"at_least_one",
"VM-COUNT . CR",
"Should be at least 1 (Mama)",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"positive",
"VM-COUNT 0 > . CR",
"Should be positive",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"CAPSULE-BIRTH",
{
{
"invalid_id",
"9999999 CAPSULE-BIRTH . CR",
"Should return -1 for invalid capsule ID",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{
"empty_stack",
"CAPSULE-BIRTH",
"Should cause stack underflow",
TEST_ERROR_CASE, 1, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"CAPSULE-RUN",
{
{
"empty_stack",
"CAPSULE-RUN",
"Should cause stack underflow",
TEST_ERROR_CASE, 1, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"CAPSULE-TEST",
{
{
"basic",
"CAPSULE-TEST",
"Should print diagnostic message",
TEST_NORMAL, 0, MAMA_IMPLEMENTED, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}} /* End marker */
};
/**
* @brief Executes all Mama FORTH vocabulary test suites
*
* In hosted builds, all tests will be skipped since MAMA_IMPLEMENTED=0.
* In kernel builds, tests will execute against the capsule system.
*
* @param vm Pointer to the Forth virtual machine instance
*/
void run_mama_forth_words_tests(VM *vm)
{
log_message(LOG_INFO, "Running Mama FORTH Words Tests (Capsule System M7.1)...");
#ifndef __STARKERNEL__
log_message(LOG_INFO, " (Hosted build - Mama words not available, tests will be skipped)");
#endif
for (int i = 0; mama_word_suites[i].word_name != NULL; i++) {
run_test_suite(vm, &mama_word_suites[i]);
}
print_module_summary("Mama FORTH Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/memory_words_test.c
+240
View File
@@ -0,0 +1,240 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/* Memory Words Test Suites - Module 3 */
static WordTestSuite memory_word_suites[] = {
{
"!", {
{"basic", "42 HERE ! HERE @ . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 HERE ! HERE @ . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-999 HERE ! HERE @ . CR", "Should print: -999", TEST_NORMAL, 0, 1, {0}},
{"overwrite", "111 HERE ! 222 HERE ! HERE @ . CR", "Should print: 222", TEST_NORMAL, 0, 1, {0}},
{"max_int", "2147483647 HERE ! HERE @ . CR", "Should store max int", TEST_EDGE_CASE, 0, 1, {0}},
{"min_int", "-2147483648 HERE ! HERE @ . CR", "Should store min int", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "!", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 !", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
8, {0}
},
{
"@", {
{"after_store", "123 HERE ! HERE @ . CR", "Should print: 123", TEST_NORMAL, 0, 1, {0}},
{"multiple_reads", "456 HERE ! HERE @ HERE @ = . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "@", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"C!", {
{"basic", "65 HERE C! HERE C@ . CR", "Should print: 65", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 HERE C! HERE C@ . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"high_byte", "255 HERE C! HERE C@ . CR", "Should print: 255", TEST_NORMAL, 0, 1, {0}},
{"truncation", "256 HERE C! HERE C@ . CR", "Should print: 0 (truncated)", TEST_EDGE_CASE, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"C@", {
{"after_cstore", "97 HERE C! HERE C@ . CR", "Should print: 97", TEST_NORMAL, 0, 1, {0}},
{"zero_byte", "0 HERE C! HERE C@ . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
",", {
{"basic", "42 , HERE 8 - @ . CR", "Should compile 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-999 , HERE 8 - @ . CR", "Should compile -999", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"C,", {
{"basic", "65 C, HERE 1 - C@ . CR", "Should compile byte 65", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 C, HERE 1 - C@ . CR", "Should compile byte 0", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"2,", {
{
"roundtrip", "12345 67890 2, HERE 16 - 2@ . . CR", "Should print: 67890 12345",
TEST_NORMAL, 0, 1, {0}
},
{
"save-and-verify", "12345 67890 2, HERE 16 - 2@ 67890 = SWAP 12345 = AND . CR",
"Should print: -1", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"HERE", {
{"basic", "HERE HERE = . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"after_comma", "HERE 42 , HERE SWAP - 1 CELLS = 0 SWAP /", "Asserts HERE advances by exactly 1 CELLS (8 bytes on 64-bit)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"ALLOT", {
{"basic", "HERE 10 ALLOT HERE SWAP - . CR", "Should print: 10", TEST_NORMAL, 0, 1, {0}},
{"zero", "HERE 0 ALLOT HERE SWAP - . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "HERE -4 ALLOT HERE SWAP - . CR", "Should print: -4", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"PAD", {
{"basic", "PAD PAD = . CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"different_from_here", "PAD HERE = . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"+!", {
{"basic", "10 HERE ! 5 HERE +! HERE @ . CR", "Should print: 15", TEST_NORMAL, 0, 1, {0}},
{"by_zero", "42 HERE ! 0 HERE +! HERE @ . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "10 HERE ! -3 HERE +! HERE @ . CR", "Should print: 7", TEST_NORMAL, 0, 1, {0}},
{"accumulate", "0 HERE ! 1 HERE +! 2 HERE +! 3 HERE +! HERE @ . CR", "Should print: 6", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "+!", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"-!", {
{"basic", "10 HERE ! 3 HERE -! HERE @ . CR", "Should print: 7", TEST_NORMAL, 0, 1, {0}},
{"by_zero", "42 HERE ! 0 HERE -! HERE @ . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "10 HERE ! -5 HERE -! HERE @ . CR", "Should print: 15", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "-!", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"2!", {
{"basic", "11 22 HERE 2! HERE @ . HERE 8 + @ . CR", "Should print: 22 11", TEST_NORMAL, 0, 1, {0}},
{"zeros", "0 0 HERE 2! HERE @ . HERE 8 + @ . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-1 -2 HERE 2! HERE @ . HERE 8 + @ . CR", "Should print: -2 -1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "2!", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"FILL", {
{"basic", "HERE 8 65 FILL HERE C@ . HERE 1+ C@ . CR", "Should print: 65 65", TEST_NORMAL, 0, 1, {0}},
{"zero_n", "HERE 0 88 FILL", "Should do nothing", TEST_NORMAL, 0, 1, {0}},
{"zero_byte", "HERE 4 0 FILL HERE C@ . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "FILL", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"MOVE", {
{"basic", "HERE 65 OVER C! HERE 1+ 66 OVER C! HERE HERE 16 + 2 MOVE HERE 16 + C@ . HERE 17 + C@ . CR", "Should print: 65 66", TEST_NORMAL, 0, 1, {0}},
{"zero_n", "HERE HERE 8 + 0 MOVE", "Should do nothing", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "MOVE", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"ERASE", {
{"basic", "HERE 4 65 FILL HERE 4 ERASE HERE C@ . HERE 3 + C@ . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"zero_n", "HERE 0 ERASE", "Should do nothing", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "ERASE", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes the test suite for memory manipulation words
* @details Runs through a series of test cases for Forth memory operations including
* store, fetch, allot, and other memory-related words
*
* @param vm Pointer to the Forth virtual machine instance
*/
void run_memory_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Memory Words Tests (Module 3)...");
WordContract mod = {CONTRACT_PHYSICS_TRANSPARENT, 0};
for (int i = 0; memory_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite_m(vm, &memory_word_suites[i], mod);
}
print_module_summary("Memory Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/mixed_arithmetic_words_test.c
+162
View File
@@ -0,0 +1,162 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/**
* @brief Module 7 test-suite table for mixed-arithmetic FORTH-79 words.
*
* Covers the five combined multiply-divide words: @c *-/ , @c *-/MOD ,
* @c M+ , @c M* , and @c M/MOD . Each suite exercises normal cases,
* edge cases (overflow, large products), and error cases (division by
* zero, stack underflow). The table is terminated with a NULL sentinel.
*/
static WordTestSuite mixed_arithmetic_word_suites[] = {
{
"*/", {
// ( n1 n2 n3 -- n4 ) n1 * n2 / n3 (integer math)
{"basic", "6 7 4 */ . CR", "Should print: 10 (6*7/4)", TEST_NORMAL, 0, 1, {0}},
{"exact_division", "12 5 3 */ . CR", "Should print: 20 (12*5/3)", TEST_NORMAL, 0, 1, {0}},
{"zero_multiply", "0 999 123 */ . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"by_one", "42 5 1 */ . CR", "Should print: 210 (42*5/1)", TEST_NORMAL, 0, 1, {0}},
{"truncation", "7 3 2 */ . CR", "Should print: 10 (21/2 truncated)", TEST_NORMAL, 0, 1, {0}},
{"negative_multiply", "-6 7 4 */ . CR", "Should print: -10", TEST_NORMAL, 0, 1, {0}},
{"negative_divisor", "6 7 -4 */ . CR", "Should print: -10", TEST_NORMAL, 0, 1, {0}},
{"div_by_zero", "6 7 0 */", "Should cause division by zero", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "*/", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"two_items", "1 2 */", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
10, {0}
},
{
"*/MOD", {
// ( n1 n2 n3 -- rem quot ) (n1*n2)/n3 -> quot, rem
{"basic", "17 3 5 */MOD . . CR", "Should print: 1 10 (51/5 = 10 rem 1)", TEST_NORMAL, 0, 1, {0}},
{"exact_division", "15 4 3 */MOD . . CR", "Should print: 0 20 (60/3 = 20 rem 0)", TEST_NORMAL, 0, 1, {0}},
{"zero_multiply", "0 999 123 */MOD . . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"by_one", "42 5 1 */MOD . . CR", "Should print: 0 210", TEST_NORMAL, 0, 1, {0}},
{"remainder", "7 8 5 */MOD . . CR", "Should print: 1 11 (56/5 = 11 rem 1)", TEST_NORMAL, 0, 1, {0}},
{"negative", "-7 3 4 */MOD . . CR", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{"div_by_zero", "6 7 0 */MOD", "Should cause division by zero", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "*/MOD", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
8, {0}
},
{
"M+", {
// ( d_lo d_hi n -- d_lo' d_hi' ) Add n to double d (low first, then high, then n)
{"basic", "0 100 200 M+ . . CR", "Should print: 200 100", TEST_NORMAL, 0, 1, {0}},
{"overflow", "0 2147483647 1 M+ . . CR", "Should handle overflow", TEST_EDGE_CASE, 0, 1, {0}},
{"negative", "0 -100 50 M+ . . CR", "Should print: 50 -100", TEST_NORMAL, 0, 1, {0}},
{"zero_add", "0 42 0 M+ . . CR", "Should print: 0 42", TEST_NORMAL, 0, 1, {0}},
{"both_negative", "0 -100 -200 M+ . . CR", "Should print: -200 -100", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "M+", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 M+", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"M*", {
// ( n1 n2 -- d_lo d_hi ) signed multiply, returns double (lo first, hi second)
{"basic", "123 456 M* . . CR", "Should print: 56088 0", TEST_NORMAL, 0, 1, {0}},
{"by_zero", "999 0 M* . . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"by_one", "42 1 M* . . CR", "Should print: 42 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-123 456 M* . . CR", "Should print: -56088 -1", TEST_NORMAL, 0, 1, {0}},
{"large_multiply", "65536 65536 M* . . CR", "Should handle large result", TEST_EDGE_CASE, 0, 1, {0}},
{"both_negative", "-100 -200 M* . . CR", "Should print: 20000 0", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "M*", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 M*", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
8, {0}
},
{
"M/MOD", {
// ( d_lo d_hi n -- rem quot ) double/single signed division (lo first, then hi, then n)
{"basic", "0 1000 100 M/MOD . . CR", "Should print: 0 10 (1000/100)", TEST_NORMAL, 0, 1, {0}},
{"with_remainder", "0 1234 100 M/MOD . . CR", "Should handle remainder", TEST_NORMAL, 0, 1, {0}},
{"double_dividend", "5001 0 10 M/MOD . . CR", "Should print: 1 500 (5001/10)", TEST_NORMAL, 0, 1, {0}},
{"by_one", "0 42 1 M/MOD . . CR", "Should print: 0 42", TEST_NORMAL, 0, 1, {0}},
{"negative_dividend", "-1 1000 100 M/MOD . . CR", "Should handle negative", TEST_NORMAL, 0, 1, {0}},
{"div_by_zero", "0 100 0 M/MOD", "Should cause division by zero", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "M/MOD", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Module 7 entry point — run all mixed-arithmetic word POST tests.
*
* Iterates @c mixed_arithmetic_word_suites and delegates each to
* @c run_test_suite(). Covers five word families:
*
* - @c *-/ ( n1 n2 n3 -- n4 ) — scale: n1*n2/n3 in 64-bit intermediate
* - @c *-/MOD ( n1 n2 n3 -- rem quot ) — scale with remainder
* - @c M+ ( d n -- d' ) — add single to double
* - @c M* ( n1 n2 -- d ) — signed multiply to double
* - @c M/MOD ( d n -- rem quot ) — double divided by single
*
* @param vm VM instance; must be initialised with the standard vocabulary.
*/
void run_mixed_arithmetic_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Mixed Arithmetic Words Tests (Module 7)...");
for (int i = 0; mixed_arithmetic_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &mixed_arithmetic_word_suites[i]);
}
print_module_summary("Mixed Arithmetic Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/physics_freeze_words_test.c
+127
View File
@@ -0,0 +1,127 @@
/*
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.
*/
/*
* physics_freeze_words_test.c — POST tests for the proof-covered subset of
* physics_freeze_words.c (Module 27)
*
* physics_freeze_words.c registers 9 words; proof/COVERAGE.md and
* proof/StarForth_Physics_Freeze_Words.thy give real (non-"True"-placeholder)
* lemmas for exactly 6 of them: FREEZE-WORD, UNFREEZE-WORD, FROZEN?, HEAT!,
* HEAT@, DECAY-RATE@. FREEZE-CRITICAL, SHOW-HEAT, and ALL-HEATS carry only
* trivial "not_modelled"/pass-through True lemmas, so they are intentionally
* left uncovered here (matches the 6/9 figure in COVERAGE.md). No test file
* for this module existed before.
*
* Each test case defines a scratch dictionary word (`:` ... `;`) and takes
* its name via S" — every word here operates on ( caddr u ), the standard
* counted-string-less pair the rest of the FORTH interpreter uses. Using
* `run_test_suite` (no WordContract) rather than `run_test_suite_m`, matching
* defining_words_tests.c's precedent: these test cases define dictionary
* words, and check_physics_transparent's own contract explicitly documents
* that its re-run mechanism does not snapshot/restore dictionary state.
*/
#include "../include/test_runner.h"
#include "../include/test_common.h"
/* Physics Freeze Words Test Suites - Module 27 */
static WordTestSuite physics_freeze_word_suites[] = {
{
"FREEZE-WORD", {
{"basic",
": __freeze_test_word__ ; S\" __freeze_test_word__\" FREEZE-WORD S\" __freeze_test_word__\" FROZEN? . CR",
"Should print: -1 (word is now frozen)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"UNFREEZE-WORD", {
{"basic",
": __unfreeze_test_word__ ; S\" __unfreeze_test_word__\" FREEZE-WORD S\" __unfreeze_test_word__\" UNFREEZE-WORD S\" __unfreeze_test_word__\" FROZEN? . CR",
"Should print: 0 (freeze cleared)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"FROZEN?", {
{"not_frozen",
": __frozen_test_word__ ; S\" __frozen_test_word__\" FROZEN? . CR",
"Should print: 0 (freshly defined word is not frozen)", TEST_NORMAL, 0, 1, {0}},
{"not_found",
"S\" __nonexistent_freeze_xyz__\" FROZEN? . CR",
"Should print: 0 (not-found treated as not frozen)", TEST_EDGE_CASE, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"HEAT!", {
{"basic",
": __heat_store_test_word__ ; 999 S\" __heat_store_test_word__\" HEAT! S\" __heat_store_test_word__\" HEAT@ . CR",
"Should print: 999", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"HEAT@", {
{"of_fresh_word",
": __heat_fetch_test_word__ ; S\" __heat_fetch_test_word__\" HEAT@ . CR",
"Should print: 0 (freshly defined word has zero heat)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"DECAY-RATE@", {
{"basic", "DECAY-RATE@ . CR",
"Should print the compile-time DECAY_RATE_PER_US_Q16 constant (no error)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes the proof-covered subset of physics-freeze word test suites
* @param vm Pointer to the Forth virtual machine instance
* @details Covers the 6 words proof/StarForth_Physics_Freeze_Words.thy gives
* real lemmas for: FREEZE-WORD, UNFREEZE-WORD, FROZEN?, HEAT!,
* HEAT@, DECAY-RATE@. Does not cover FREEZE-CRITICAL, SHOW-HEAT, or
* ALL-HEATS — those carry only trivial/not-modelled lemmas in the
* same theory file.
*/
void run_physics_freeze_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Physics Freeze Words Tests (Module 27)...");
for (int i = 0; physics_freeze_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &physics_freeze_word_suites[i]);
}
print_module_summary("Physics Freeze Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/q48_words_test.c
+230
View File
@@ -0,0 +1,230 @@
/*
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.
*/
/*
* q48_words_test.c — POST tests for Q48.16 fixed-point words (Module 25)
*
* Proof-covered per proof/COVERAGE.md (StarForth_Q48_Words.thy, 17/23) but
* had no interpreter-level POST coverage at all before this file — no test
* file for q48_words.c existed. Values are built with Q.FROM-INT/Q.1/Q.0
* and read back with Q.TO-INT so results print as plain readable integers;
* pass/fail itself is judged only by vm->error (matching every other
* WordTestSuite-based module), so exact printed values are for a human
* reading the log, not machine-verified — same convention arithmetic_words_
* test.c already uses for its own "Should print: N" fields.
*/
#include "../include/test_runner.h"
#include "../include/test_common.h"
/* Q48.16 Words Test Suites - Module 25 */
static WordTestSuite q48_word_suites[] = {
{
"Q.+", {
{"basic", "1 Q.FROM-INT 2 Q.FROM-INT Q.+ Q.TO-INT . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.-", {
{"basic", "5 Q.FROM-INT 2 Q.FROM-INT Q.- Q.TO-INT . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.*", {
{"basic", "3 Q.FROM-INT 4 Q.FROM-INT Q.* Q.TO-INT . CR", "Should print: 12", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q./", {
{"basic", "10 Q.FROM-INT 2 Q.FROM-INT Q./ Q.TO-INT . CR", "Should print: 5", TEST_NORMAL, 0, 1, {0}},
{"by_zero", "5 Q.FROM-INT 0 Q.FROM-INT Q./ Q.TO-INT . CR", "Should print: 0 (division by zero yields q=0)", TEST_EDGE_CASE, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"Q.ABS", {
{"basic", "3 Q.FROM-INT Q.NEG Q.ABS Q.TO-INT . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.NEG", {
{"basic", "5 Q.FROM-INT Q.NEG Q.TO-INT . CR", "Should print: -5", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.LOG", {
{"of_one", "Q.1 Q.LOG Q.TO-INT . CR", "Should print: 0 (ln 1.0 = 0)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.EXP", {
{"of_zero", "Q.0 Q.EXP Q.TO-INT . CR", "Should print: 1 (e^0 = 1)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.SQRT", {
{"of_four", "4 Q.FROM-INT Q.SQRT Q.TO-INT . CR", "Should print: 2", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.SIN", {
{"of_zero", "Q.0 Q.SIN Q.TO-INT . CR", "Should print: 0 (sin 0 = 0)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.COS", {
{"of_zero", "Q.0 Q.COS Q.TO-INT . CR", "Should print: 1 (cos 0 = 1)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.FROM-INT", {
{"round_trip", "7 Q.FROM-INT Q.TO-INT . CR", "Should print: 7", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.TO-INT", {
{"of_one", "Q.1 Q.TO-INT . CR", "Should print: 1", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.1", {
{"raw_value", "Q.1 . CR", "Should print: 65536", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.0", {
{"raw_value", "Q.0 . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.SCALE", {
{"raw_value", "Q.SCALE . CR", "Should print: 65536", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.=", {
{"equal", "Q.1 Q.1 Q.= . CR", "Should print: -1 (true)", TEST_NORMAL, 0, 1, {0}},
{"not_equal", "Q.1 Q.0 Q.= . CR", "Should print: 0 (false)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"Q.<", {
{"true", "Q.0 Q.1 Q.< . CR", "Should print: -1 (true)", TEST_NORMAL, 0, 1, {0}},
{"false", "Q.1 Q.0 Q.< . CR", "Should print: 0 (false)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"Q.>", {
{"true", "Q.1 Q.0 Q.> . CR", "Should print: -1 (true)", TEST_NORMAL, 0, 1, {0}},
{"false", "Q.0 Q.1 Q.> . CR", "Should print: 0 (false)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"Q.0=", {
{"true", "Q.0 Q.0= . CR", "Should print: -1 (true)", TEST_NORMAL, 0, 1, {0}},
{"false", "Q.1 Q.0= . CR", "Should print: 0 (false)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"Q.MAX", {
{"basic", "3 Q.FROM-INT 7 Q.FROM-INT Q.MAX Q.TO-INT . CR", "Should print: 7", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.MIN", {
{"basic", "3 Q.FROM-INT 7 Q.FROM-INT Q.MIN Q.TO-INT . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"Q.PRINT", {
{"of_one", "Q.1 Q.PRINT CR", "Should print: 1.00000", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all Q48.16 fixed-point word test suites
* @param vm Pointer to the Forth virtual machine instance
* @details Covers all 23 words registered by register_q48_words()
* (q48_words.c): arithmetic (+, -, *, /), sign (ABS, NEG),
* transcendental approximations (LOG, EXP, SQRT, SIN, COS),
* conversions (FROM-INT, TO-INT), constants (1, 0, SCALE),
* comparisons (=, <, >, 0=, MAX, MIN), and PRINT.
*/
void run_q48_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Q48.16 Words Tests (Module 25)...");
WordContract mod = {CONTRACT_PHYSICS_TRANSPARENT, 0};
for (int i = 0; q48_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite_m(vm, &q48_word_suites[i], mod);
}
print_module_summary("Q48.16 Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/return_stack_words_test.c
+104
View File
@@ -0,0 +1,104 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/**
* @brief Test suites for return stack manipulation words
* @details Contains test cases for >R (push to return stack),
* R> (pop from return stack), and R@ (copy top of return stack)
*/
static WordTestSuite return_stack_word_suites[] = {
{
">R", {
{"basic", "42 >R R@ . R> . CR", "Should print: 42 42", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 >R R@ . R> . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-123 >R R@ . R> . CR", "Should print: -123 -123", TEST_NORMAL, 0, 1, {0}},
{"multiple", "1 2 >R >R R@ . R> . R@ . R> . CR", "Should print: 2 2 1 1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", ">R", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"R>", {
{"basic", "42 >R R> . CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"lifo_order", "1 2 >R >R R> . R> . CR", "Should print: 2 1", TEST_NORMAL, 0, 1, {0}},
{"empty_rstack", "R>", "Should cause return stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"R@", {
{"basic", "42 >R R@ . R> DROP CR", "Should print: 42", TEST_NORMAL, 0, 1, {0}},
{"non_destructive", "99 >R R@ R@ = . R> DROP CR", "Should print: -1", TEST_NORMAL, 0, 1, {0}},
{"empty_rstack", "R@", "Should cause return stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all test suites for return stack manipulation words
* @param vm Pointer to the Forth virtual machine instance
* @details Runs through all defined test cases for >R, R>, and R@ words
* and reports results_run_01_2025_12_08 through the logging system
*/
void run_return_stack_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Return Stack Words Tests (Module 2)...");
WordContract mod = {CONTRACT_PHYSICS_TRANSPARENT, 0};
for (int i = 0; return_stack_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite_m(vm, &return_stack_word_suites[i], mod);
}
print_module_summary("Return Stack Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/stack_words_test.c
+215
View File
@@ -0,0 +1,215 @@
/*
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.
*/
/**
* @file stack_words_test.c
* @brief Test module for Forth stack manipulation words
* @details Contains test suites for basic stack operations including
* DUP, DROP, SWAP, OVER, ROT, DEPTH, PICK, and ROLL
*/
#include "../include/test_runner.h"
#include "../include/test_common.h"
/**
* @brief Test suites for stack manipulation words
* @details Contains comprehensive test cases for all standard stack operations,
* including normal cases, edge cases, and error conditions
*/
static WordTestSuite stack_word_suites[] = {
{
"DUP", {
{"basic", "5 DUP . . CR", "Should print: 5 5", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 DUP . . CR", "Should print: 0 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-42 DUP . . CR", "Should print: -42 -42", TEST_NORMAL, 0, 1, {0}},
{"max_int", "2147483647 DUP . . CR", "Should duplicate max int", TEST_EDGE_CASE, 0, 1, {0}},
{"min_int", "-2147483648 DUP . . CR", "Should duplicate min int", TEST_EDGE_CASE, 0, 1, {0}},
{"empty_stack", "DUP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"DROP", {
/* Basic functionality */
{"basic", "5 7 DROP . CR", "Should print: 5", TEST_NORMAL, 0, 1, {0}},
{"zero", "42 0 DROP . CR", "Should drop zero, print 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "10 -5 DROP . CR", "Should drop negative, print 10", TEST_NORMAL, 0, 1, {0}},
/* Multiple drops */
{"double_drop", "1 2 3 DROP DROP . CR", "Should print: 1", TEST_NORMAL, 0, 1, {0}},
{"triple_drop", "1 2 3 4 DROP DROP DROP . CR", "Should print: 1", TEST_NORMAL, 0, 1, {0}},
{"sequential", "5 DROP 6 DROP 7 . CR", "Should print: 7", TEST_NORMAL, 0, 1, {0}},
/* Stack depth effects */
{"single_item", "99 DROP DEPTH . CR", "Should empty stack, depth=0", TEST_NORMAL, 0, 1, {0}},
{"depth_change", "DEPTH 1 2 DROP DEPTH SWAP - . CR", "Should change depth by 1", TEST_NORMAL, 0, 1, {0}},
{"preserve_depth", "DEPTH 5 6 DROP DROP DEPTH = . CR", "Should preserve net depth", TEST_NORMAL, 0, 1, {0}},
/* Edge cases */
{"max_int", "2147483647 DROP DEPTH . CR", "Should drop max int", TEST_NORMAL, 0, 1, {0}},
{"min_int", "-2147483648 DROP DEPTH . CR", "Should drop min int", TEST_NORMAL, 0, 1, {0}},
/* Chaining with other operations */
{"with_dup", "5 DUP DROP . CR", "Should duplicate then drop", TEST_NORMAL, 0, 1, {0}},
{"with_swap", "1 2 SWAP DROP . CR", "Should swap then drop", TEST_NORMAL, 0, 1, {0}},
{"complex", "1 2 3 ROT DROP SWAP DROP . CR", "Should handle complex sequence", TEST_NORMAL, 0, 1, {0}},
/* Error case */
{"empty_stack", "DROP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
15, {0}
},
{
"SWAP", {
{"basic", "5 7 SWAP . . CR", "Should print: 7 5", TEST_NORMAL, 0, 1, {0}},
{"same_values", "42 42 SWAP . . CR", "Should print: 42 42", TEST_NORMAL, 0, 1, {0}},
{"zero_nonzero", "0 99 SWAP . . CR", "Should print: 99 0", TEST_NORMAL, 0, 1, {0}},
{"negative", "-5 10 SWAP . . CR", "Should print: 10 -5", TEST_NORMAL, 0, 1, {0}},
{"one_item", "42 SWAP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "SWAP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"OVER", {
{"basic", "5 7 OVER . . . CR", "Should print: 5 7 5", TEST_NORMAL, 0, 1, {0}},
{"zeros", "0 0 OVER . . . CR", "Should print: 0 0 0", TEST_NORMAL, 0, 1, {0}},
{"mixed", "-1 42 OVER . . . CR", "Should print: -1 42 -1", TEST_NORMAL, 0, 1, {0}},
{"one_item", "42 OVER", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "OVER", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"ROT", {
{"basic", "1 2 3 ROT . . . CR", "Should print: 2 3 1", TEST_NORMAL, 0, 1, {0}},
{"zeros", "0 0 0 ROT . . . CR", "Should print: 0 0 0", TEST_NORMAL, 0, 1, {0}},
{"mixed", "-1 0 1 ROT . . . CR", "Should print: 0 1 -1", TEST_NORMAL, 0, 1, {0}},
{"two_items", "1 2 ROT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"one_item", "42 ROT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "ROT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"DEPTH", {
{"empty", "DEPTH . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"one_item", "42 DEPTH . CR", "Should print: 1", TEST_NORMAL, 0, 1, {0}},
{"multiple", "1 2 3 DEPTH . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"PICK", {
{"pick_0", "1 2 3 0 PICK . CR", "Should print: 3", TEST_NORMAL, 0, 1, {0}},
{"pick_1", "1 2 3 1 PICK . CR", "Should print: 2", TEST_NORMAL, 0, 1, {0}},
{"pick_2", "1 2 3 2 PICK . CR", "Should print: 1", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"ROLL", {
{"roll_1", "1 2 3 1 ROLL . . . CR", "Should print: 1 3 2", TEST_NORMAL, 0, 1, {0}},
{"roll_2", "1 2 3 2 ROLL . . . CR", "Should print: 2 3 1", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"?DUP", {
{"nonzero", "42 ?DUP . . CR", "Should print: 42 42", TEST_NORMAL, 0, 1, {0}},
{"negative", "-5 ?DUP . . CR", "Should print: -5 -5", TEST_NORMAL, 0, 1, {0}},
{"zero", "0 ?DUP DEPTH . CR", "Should not dup: depth 1", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "?DUP", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"-ROT", {
{"basic", "1 2 3 -ROT . . . CR", "Should print: 1 3 2", TEST_NORMAL, 0, 1, {0}},
{"zeros", "0 0 0 -ROT . . . CR", "Should print: 0 0 0", TEST_NORMAL, 0, 1, {0}},
{"roundtrip", "1 2 3 -ROT ROT . . . CR", "Should restore original order", TEST_NORMAL, 0, 1, {0}},
{"two_items", "1 2 -ROT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "-ROT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all test suites for stack manipulation words
* @param vm Pointer to the Forth virtual machine instance
* @details Runs through all defined test cases for stack manipulation words
* and reports results_run_01_2025_12_08 through the logging system
*/
void run_stack_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Stack Words Tests (Module 1: Foundation)...");
WordContract mod = {CONTRACT_PHYSICS_TRANSPARENT, 0};
for (int i = 0; stack_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite_m(vm, &stack_word_suites[i], mod);
}
print_module_summary("Stack Words", 0, 0, 0, 0); /* Will be calculated by test_suite */
}
v3/src/test_runner/modules/starforth_words_test.c
+222
View File
@@ -0,0 +1,222 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/**
* @brief Test suites for StarForth-specific words
*
* Contains test cases for the following StarForth implementation words:
* - ENTROPY@: Fetch word execution count
* - ENTROPY!: Store word execution count
* - WORD-ENTROPY: Get execution count for a word by name
* - RESET-ENTROPY: Reset all word execution counts
* - TOP-WORDS: Display most frequently executed words
* - (-: Comment to end of line
* - INIT: System initialization
*/
static WordTestSuite starforth_word_suites[] = {
{
"ENTROPY@", {
/* Basic functionality - ' returns xt (DictEntry*), NOT body address */
{
"after_execution", ": TESTWORD 1 1 + DROP ; TESTWORD ' TESTWORD ENTROPY@ . CR",
"Should show execution count > 0", TEST_NORMAL, 0, 1, {0}
},
{
"zero_initial", ": NEWWORD ; ' NEWWORD ENTROPY@ . CR",
"Should show 0 for unused word", TEST_NORMAL, 0, 1, {0}
},
/* Multiple executions */
{
"multiple_calls", ": ENTTEST 1 DROP ; ENTTEST ENTTEST ENTTEST ' ENTTEST ENTROPY@ . CR",
"Should increment with each call", TEST_NORMAL, 0, 1, {0}
},
/* Error cases */
{"null_addr", "0 ENTROPY@", "Should handle null address", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "ENTROPY@", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"ENTROPY!", {
/* Basic functionality - ' returns xt (DictEntry*), NOT body address */
{
"set_entropy", ": ENTSET ; 42 ' ENTSET ENTROPY! ' ENTSET ENTROPY@ . CR",
"Should set entropy to 42", TEST_NORMAL, 0, 1, {0}
},
{
"overwrite",
": ENTOV ; 10 ' ENTOV ENTROPY! 20 ' ENTOV ENTROPY! ' ENTOV ENTROPY@ . CR",
"Should overwrite previous value", TEST_NORMAL, 0, 1, {0}
},
{
"zero_entropy", ": ENTZERO ; 0 ' ENTZERO ENTROPY! ' ENTZERO ENTROPY@ . CR",
"Should set entropy to 0", TEST_NORMAL, 0, 1, {0}
},
/* Error cases */
{"null_addr", "42 0 ENTROPY!", "Should handle null address", TEST_ERROR_CASE, 1, 1, {0}},
{"one_arg", "42 ENTROPY!", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{"empty_stack", "ENTROPY!", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"WORD-ENTROPY", {
/* Basic functionality - WORD-ENTROPY just prints stats, no stack interaction */
{
"display_all", "1 DUP DUP DUP DROP DROP DROP DROP WORD-ENTROPY",
"Should display all word entropy stats", TEST_NORMAL, 0, 1, {0}
},
{
"after_execution", ": WDENT 1 2 + DROP ; WDENT WDENT WORD-ENTROPY",
"Should show defined word entropy", TEST_NORMAL, 0, 1, {0}
},
/* No stack effect */
{
"stack_preserved", "DEPTH WORD-ENTROPY DEPTH = . CR",
"Should not affect stack", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"RESET-ENTROPY", {
/* Basic functionality */
{
"reset_defined", ": RESETTEST 1 DROP ; RESETTEST RESETTEST RESETTEST RESET-ENTROPY",
"Should reset all entropy counters", TEST_NORMAL, 0, 1, {0}
},
/* Idempotent */
{"double_reset", "RESET-ENTROPY RESET-ENTROPY", "Should handle multiple resets", TEST_NORMAL, 0, 1, {0}},
/* Verify it runs without error */
{
"after_usage", "1 DUP DUP DUP DROP DROP DROP DROP RESET-ENTROPY", "Should reset after word usage",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"TOP-WORDS", {
/* Basic functionality - TOP-WORDS requires ( n -- ) stack parameter */
{
"display_top5", ": TOPTEST 1 DROP ; TOPTEST TOPTEST TOPTEST TOPTEST TOPTEST 5 TOP-WORDS",
"Should display top 5 hot words", TEST_NORMAL, 0, 1, {0}
},
{"display_top10", "10 TOP-WORDS", "Should display top 10 words", TEST_NORMAL, 0, 1, {0}},
{"after_reset", "RESET-ENTROPY 5 TOP-WORDS", "Should handle display after reset", TEST_NORMAL, 0, 1, {0}},
/* Different counts */
{"single_word", "1 TOP-WORDS", "Should display top 1 word", TEST_NORMAL, 0, 1, {0}},
{"large_count", "100 TOP-WORDS", "Should handle large count", TEST_NORMAL, 0, 1, {0}},
/* Error cases */
{"zero_count", "0 TOP-WORDS", "Should handle zero count", TEST_NORMAL, 0, 1, {0}},
{"negative_count", "-5 TOP-WORDS", "Should handle negative count", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "TOP-WORDS", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
8, {0}
},
{
"(-", {
/* Basic functionality */
{"comment_line", "(- This is a comment\n1 2 + . CR", "Should ignore rest of line", TEST_NORMAL, 0, 1, {0}},
{"mid_line", "1 (- comment here\n2 + . CR", "Should work mid-expression", TEST_NORMAL, 0, 1, {0}},
/* Stack preservation */
{"no_stack_effect", "DEPTH (- comment\nDEPTH = . CR", "Should not affect stack", TEST_NORMAL, 0, 1, {0}},
/* Multiple comments */
{"multiple", "1 (- first\n2 (- second\n+ . CR", "Should handle multiple comments", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
/* INIT intentionally not tested here - it's a startup operation that loads
* and executes init.4th. Running it during POST would cause double-initialization. */
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all StarForth words test suites
* @param vm Pointer to the FORTH virtual machine instance
*
* Runs through all test cases for StarForth-specific implementation words,
* including entropy tracking, comments, and initialization.
*/
void run_starforth_words_tests(VM *vm) {
log_message(LOG_INFO, "Running StarForth Words Tests (Module 17: StarForth Extensions)...");
for (int i = 0; starforth_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &starforth_word_suites[i]);
}
print_module_summary("StarForth Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/stress_tests.c
+365
View File
@@ -0,0 +1,365 @@
/*
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.
*/
/**
* @file stress_tests.c
* @brief FORTH-79 Standard Comprehensive Stress Testing Module
*
* This module contains extensive stress tests that verify the interpreter's behavior
* under extreme conditions while remaining within FORTH-79 standard compliance.
*
* Test categories (expanded):
* - Deep nesting of control structures (up to 5 levels)
* - Stack exhaustion and boundary tests (near-limit operations)
* - Numeric boundary conditions (cell_t min/max, overflow)
* - Dictionary pressure (many definitions, long names)
* - Word execution chains (deep call stacks)
* - Control flow edge cases (empty loops, large counts, EXIT)
* - Memory allocation patterns (fragmentation, large blocks)
* - Error recovery (ABORT, stack underflow recovery)
* - Large definitions and word chains
*
* IMPORTANT: These tests only use FORTH-79 standard words. Features from
* later standards (ANS Forth 1994, Forth 2012) are NOT tested here:
* - RECURSE (ANS Forth) - not in FORTH-79
* - Self-referential definitions - not supported in FORTH-79
* - Extended VARIABLE usage - only standard semantics tested
*
* For testing extended/non-standard features, see integration_tests.c
*/
#include <stdio.h>
#include "test_common.h"
#include "test_runner.h"
/* Comprehensive stress test suites */
static WordTestSuite stress_suites[] = {
/* ===== 1. STACK DEPTH TESTS ===== */
{
"STACK_DEPTH", {
{"deep_push", ": PUSH-100 0 100 0 DO I LOOP ; PUSH-100 DEPTH . CR", "Push 100 items", TEST_NORMAL, 0, 1, {0}},
{"deep_math", ": MATH-STRESS 1 100 0 DO 1+ LOOP . CR ; MATH-STRESS", "100 additions", TEST_NORMAL, 0, 1, {0}},
{
"dup_stress", ": DUP-STRESS 42 50 0 DO DUP LOOP DEPTH . CR 51 0 DO DROP LOOP ; DUP-STRESS", "50 DUPs",
TEST_NORMAL, 0, 1, {0}
},
{
"deep_push_200",
": PUSH-200 0 200 0 DO I LOOP ; : CLR-200 200 0 DO DROP LOOP ; PUSH-200 DEPTH . CR CLR-200",
"Push 200 items", TEST_NORMAL, 0, 1, {0}
},
{
"mixed_ops", ": MIXED 1 2 3 4 5 6 7 8 9 10 50 0 DO SWAP ROT LOOP 10 0 DO DROP LOOP ; MIXED",
"Mixed stack ops", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
/* ===== 2. STACK BOUNDARY TESTS ===== */
{
"STACK_BOUNDARY", {
{
"near_limit_900",
": PUSH-900 0 900 0 DO I LOOP ; : CLR-900 900 0 DO DROP LOOP ; PUSH-900 DEPTH . CR CLR-900 FORGET CLR-900",
"Push 900 items (near 1024 limit)", TEST_EDGE_CASE, 0, 1, {0}
},
{"underflow_detect", "DROP", "Stack underflow detection", TEST_ERROR_CASE, 1, 1, {0}},
{"dup_underflow", "DUP", "DUP underflow detection", TEST_ERROR_CASE, 1, 1, {0}},
{"swap_underflow", "1 SWAP", "SWAP underflow detection", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
/* ===== 3. RETURN STACK STRESS ===== */
{
"RETURN_STACK", {
{"basic_to_r", "1 2 3 >R >R >R R> R> R> + + . CR", "Basic >R/R> test", TEST_NORMAL, 0, 1, {0}},
{"r_fetch", "42 >R R@ . CR R> DROP", "R@ test", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
/* ===== 4. DEEP NESTING TESTS ===== */
{
"DEEP_NESTING", {
{
"nested_if_5",
": NEST5 DUP 0> IF DUP 10 > IF DUP 20 > IF DUP 30 > IF DUP 40 > IF 5 ELSE 4 THEN ELSE 3 THEN ELSE 2 THEN ELSE 1 THEN ELSE 0 THEN . CR ; 45 NEST5",
"5-level IF nesting", TEST_NORMAL, 0, 1, {0}
},
{
"nested_loops_4", ": NEST-4 0 2 0 DO 2 0 DO 2 0 DO 2 0 DO 1+ LOOP LOOP LOOP LOOP . CR ; NEST-4",
"4-level DO loop nesting", TEST_NORMAL, 0, 1, {0}
},
{
"mixed_if_do", ": MIX-NEST 0 10 0> IF 5 0 DO 1+ LOOP ELSE 3 0 DO 2 + LOOP THEN . CR ; MIX-NEST",
"IF with DO inside", TEST_NORMAL, 0, 1, {0}
},
{
"begin_simple", ": BEGIN-TEST 5 BEGIN 1- DUP 0= UNTIL DROP ; BEGIN-TEST",
"Simple BEGIN/UNTIL loop", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
/* ===== 5. CONTROL FLOW EDGE CASES ===== */
{
"CONTROL_EDGE", {
{"empty_loop", ": EMPTY-LOOP 0 0 DO LOOP ; EMPTY-LOOP", "Empty loop body", TEST_NORMAL, 0, 1, {0}},
{"single_iter", ": SINGLE 1 0 DO 42 . LOOP CR ; SINGLE", "Single iteration", TEST_NORMAL, 0, 1, {0}},
{"large_count", ": BIG-LOOP 0 10000 0 DO 1+ LOOP . CR ; BIG-LOOP", "10000 iterations", TEST_NORMAL, 0, 1, {0}},
{
"nested_exit", ": NEST-EXIT 10 0 DO I 5 = IF EXIT THEN I . LOOP CR ; NEST-EXIT", "EXIT in nested loop",
TEST_NORMAL, 0, 1, {0}
},
{
"begin_while", ": B-W-R 10 BEGIN DUP 0> WHILE DUP . 1- REPEAT DROP CR ; B-W-R", "BEGIN WHILE REPEAT",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
/* ===== 6. NUMERIC BOUNDARIES ===== */
{
"NUMERIC_BOUNDARY", {
{"max_int", ": MAX-TEST 2147483647 DUP . 1+ . CR ; MAX-TEST", "Max int boundary", TEST_EDGE_CASE, 0, 1, {0}},
{"min_int", ": MIN-TEST -2147483648 DUP . 1- . CR ; MIN-TEST", "Min int boundary", TEST_EDGE_CASE, 0, 1, {0}},
{"large_mult", ": BIG-MULT 10000 10000 * . CR ; BIG-MULT", "Large multiplication", TEST_NORMAL, 0, 1, {0}},
{
"div_edge", ": DIV-TEST 100 1 / 100 2 / 100 3 / . . . CR ; DIV-TEST", "Division edge cases",
TEST_NORMAL, 0, 1, {0}
},
{"mod_edge", ": MOD-TEST 100 7 MOD 100 3 MOD . . CR ; MOD-TEST", "Modulo operations", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
/* ===== 7. WORD EXECUTION CHAINS ===== */
{
"EXEC_CHAINS", {
{
"chain_10",
": C1 1 ; : C2 C1 1+ ; : C3 C2 1+ ; : C4 C3 1+ ; : C5 C4 1+ ; : C6 C5 1+ ; : C7 C6 1+ ; : C8 C7 1+ ; : C9 C8 1+ ; : C10 C9 1+ ; C10 . CR",
"10-word call chain", TEST_NORMAL, 0, 1, {0}
},
{
"chain_20",
": D1 1 ; : D2 D1 1+ ; : D3 D2 1+ ; : D4 D3 1+ ; : D5 D4 1+ ; : D6 D5 1+ ; : D7 D6 1+ ; : D8 D7 1+ ; : D9 D8 1+ ; : D10 D9 1+ ; : D11 D10 1+ ; : D12 D11 1+ ; : D13 D12 1+ ; : D14 D13 1+ ; : D15 D14 1+ ; : D16 D15 1+ ; : D17 D16 1+ ; : D18 D17 1+ ; : D19 D18 1+ ; : D20 D19 1+ ; D20 . CR",
"20-word call chain", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
/* ===== 8. LARGE DEFINITIONS ===== */
{
"LARGE_DEF", {
{
"long_sequence_50",
": LONG50 1 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ 1+ . CR ; LONG50",
"50+ operations", TEST_NORMAL, 0, 1, {0}
},
{
"many_literals",
": LITS 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + + + + + + + + + + + + + + + + + + + . CR ; LITS",
"20 literals", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
/* ===== 9. DICTIONARY PRESSURE ===== */
{
"DICT_PRESSURE", {
{
"many_defs",
": T1 1 ; : T2 2 ; : T3 3 ; : T4 4 ; : T5 5 ; : T6 6 ; : T7 7 ; : T8 8 ; : T9 9 ; : T10 10 ; : T11 11 ; : T12 12 ; : T13 13 ; : T14 14 ; : T15 15 ; : T16 16 ; : T17 17 ; : T18 18 ; : T19 19 ; : T20 20 ; T20 . CR",
"20 word definitions", TEST_NORMAL, 0, 1, {0}
},
{
"long_name", ": VERY-LONG-WORD-NAME-TEST-MAX 42 . CR ; VERY-LONG-WORD-NAME-TEST-MAX",
"Long word name (31 chars)", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
/* ===== 10. MEMORY ALLOCATION STRESS ===== */
{
"MEMORY_STRESS", {
{
"allot_100", ": ALLOT-100 HERE 100 ALLOT HERE SWAP - . CR ; ALLOT-100", "ALLOT 100 bytes", TEST_NORMAL, 0, 1, {0}
},
{"allot_1000", ": ALLOT-1K HERE 1000 ALLOT HERE SWAP - . CR ; ALLOT-1K", "ALLOT 1KB", TEST_NORMAL, 0, 1, {0}},
{"allot_8k", ": ALLOT-8K HERE 8192 ALLOT HERE SWAP - . CR ; ALLOT-8K", "ALLOT 8KB", TEST_NORMAL, 0, 1, {0}},
{
"multiple_allots", ": MULTI-ALLOT HERE 10 ALLOT 20 ALLOT 30 ALLOT HERE SWAP - . CR ; MULTI-ALLOT",
"Multiple ALLOTs", TEST_NORMAL, 0, 1, {0}
},
{
"allot_pattern", ": PATTERN 5 0 DO HERE 100 ALLOT DROP LOOP ; PATTERN", "Repeated allot pattern",
TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
/* ===== 11. ERROR RECOVERY ===== */
{
"ERROR_RECOVERY", {
{"abort_recovery", ": AB-TEST 1 2 3 ABORT ; AB-TEST DEPTH . CR", "ABORT clears stacks", TEST_NORMAL, 0, 1, {0}},
{"continue_after_abort", "ABORT 42 . CR", "Can continue after ABORT", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
/* ===== 12. DOUBLE NUMBER STRESS ===== */
{
"DOUBLE_STRESS", {
{"large_double_add", "1000000 0 2000000 0 D+ . . CR", "Large double addition", TEST_NORMAL, 0, 1, {0}},
{"double_chain", "100 200 2DUP D+ . . CR", "Double operation chain", TEST_NORMAL, 0, 1, {0}},
{"double_negate", "100 200 DNEGATE DNEGATE . . CR", "Double negate twice", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
/* ===== 13. MIXED COMPLEXITY ===== */
{
"MIXED_COMPLEX", {
{
"nested_if_do",
": COMPLEX 10 0 DO I DUP 5 > IF 2 * ELSE 3 + THEN . LOOP CR ; COMPLEX",
"Mixed IF/DO", TEST_NORMAL, 0, 1, {0}
},
{
"nested_begin_do",
": NB-DO 5 BEGIN DUP 0> WHILE DUP 3 0 DO I . LOOP CR 1- REPEAT DROP ; NB-DO",
"Nested BEGIN/DO", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
/* ===== 14. STRING/BUFFER EDGE CASES ===== */
{
"STRING_EDGE", {
{"empty_def", ": EMPTY ; EMPTY", "Empty definition", TEST_NORMAL, 0, 1, {0}},
{"single_word", ": SINGLE DUP ; 42 SINGLE . . CR", "Single word def", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
};
/**
* @brief Execute comprehensive stress test suites
*
* Runs an extensive set of stress tests to verify the VM's behavior
* under extreme conditions. Tests include:
* - Stack operations and boundaries
* - Deep nesting and control flow
* - Numeric boundaries and overflow
* - Dictionary pressure
* - Memory allocation patterns
* - Error recovery
* - Mixed complexity scenarios
*
* All tests are FORTH-79 compliant.
*
* @param vm Pointer to the Forth virtual machine instance
*/
void run_stress_tests(VM *vm) {
if (!vm) return;
// Reset global stats for stress tests
extern TestStats global_test_stats;
global_test_stats.total_tests = 0;
global_test_stats.total_pass = 0;
global_test_stats.total_fail = 0;
global_test_stats.total_skip = 0;
global_test_stats.total_error = 0;
log_message(LOG_INFO, "==============================================");
log_message(LOG_INFO, " StarForth Comprehensive Stress Test Suite");
log_message(LOG_INFO, " FORTH-79 Standard Compliance");
log_message(LOG_INFO, "==============================================\n");
for (size_t i = 0; i < sizeof(stress_suites) / sizeof(WordTestSuite); i++) {
log_message(LOG_TEST, "▶ Testing category: %s", stress_suites[i].word_name);
run_test_suite(vm, &stress_suites[i]);
}
log_message(LOG_INFO, "==============================================");
log_message(LOG_INFO, " COMPREHENSIVE STRESS TEST RESULTS");
log_message(LOG_INFO, "==============================================");
log_message(LOG_INFO, " Total tests: %d", global_test_stats.total_tests);
log_message(LOG_INFO, " Passed: %d", global_test_stats.total_pass);
log_message(LOG_INFO, " Failed: %d", global_test_stats.total_fail);
log_message(LOG_INFO, " Skipped: %d", global_test_stats.total_skip);
log_message(LOG_INFO, " Errors: %d", global_test_stats.total_error);
if (global_test_stats.total_fail == 0 && global_test_stats.total_error == 0) {
log_message(LOG_INFO, "\n ✓ ALL STRESS TESTS PASSED!");
log_message(LOG_INFO, " StarForth demonstrates excellent stability");
log_message(LOG_INFO, " under extreme FORTH-79 workload conditions.");
} else {
log_message(LOG_INFO, "\n ✗ SOME TESTS FAILED");
log_message(LOG_INFO, " Review output above for details");
}
log_message(LOG_INFO, "==============================================\n");
}
v3/src/test_runner/modules/string_words_test.c
+219
View File
@@ -0,0 +1,219 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/* String Words Test Suites - Module 11 */
static WordTestSuite string_word_suites[] = {
{
"COUNT", {
{"basic", "HERE S\" Test\" DROP COUNT . . CR", "Should show length and addr+1", TEST_NORMAL, 0, 1, {0}},
{"empty", "HERE 0 OVER C! COUNT . . CR", "Should handle empty string", TEST_NORMAL, 0, 1, {0}},
{"max_length", "HERE 255 OVER C! COUNT . . CR", "Should handle max length", TEST_NORMAL, 0, 1, {0}},
{"string_bounds", "HERE COUNT SWAP 1- = . CR", "Should increment address", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "COUNT", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"-TRAILING", {
{"basic", "HERE S\" Test \" -TRAILING TYPE CR", "Should trim spaces", TEST_NORMAL, 0, 1, {0}},
{"all_spaces", "HERE S\" \" -TRAILING TYPE CR", "Should handle all spaces", TEST_NORMAL, 0, 1, {0}},
{"no_spaces", "HERE S\" Test\" -TRAILING TYPE CR", "Should handle no spaces", TEST_NORMAL, 0, 1, {0}},
{"empty", "HERE 0 -TRAILING TYPE CR", "Should handle empty string", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"CMOVE", {
{"basic", "HERE S\" Test\" DUP >R HERE 10 + SWAP CMOVE CR", "Should copy string", TEST_NORMAL, 0, 1, {0}},
{"empty", "HERE HERE 10 + 0 CMOVE", "Should handle zero count", TEST_NORMAL, 0, 1, {0}},
{"overlap", "HERE DUP 1+ 5 CMOVE", "Should handle overlap", TEST_NORMAL, 0, 1, {0}},
{"bounds", "HERE PAD 1000 CMOVE", "Should check bounds", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"CMOVE>", {
{"basic", "HERE S\" Test\" DUP >R HERE 10 + SWAP CMOVE> CR", "Should copy backward", TEST_NORMAL, 0, 1, {0}},
{"empty", "HERE HERE 10 + 0 CMOVE>", "Should handle zero count", TEST_NORMAL, 0, 1, {0}},
{"overlap", "HERE DUP 1+ 5 CMOVE>", "Should handle overlap", TEST_NORMAL, 0, 1, {0}},
{"bounds", "HERE PAD 1000 CMOVE>", "Should check bounds", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"COMPARE", {
{"equal", "HERE S\" Test\" HERE S\" Test\" COMPARE . CR", "Should return 0", TEST_NORMAL, 0, 1, {0}},
{"less", "HERE S\" Test1\" HERE S\" Test2\" COMPARE . CR", "Should return -1", TEST_NORMAL, 0, 1, {0}},
{"greater", "HERE S\" Test2\" HERE S\" Test1\" COMPARE . CR", "Should return 1", TEST_NORMAL, 0, 1, {0}},
{
"different_lengths", "HERE S\" Test\" HERE S\" Testing\" COMPARE . CR", "Should handle lengths",
TEST_NORMAL, 0, 1, {0}
},
{"empty", "HERE 0 HERE 0 COMPARE . CR", "Should handle empty", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
5, {0}
},
{
"SEARCH", {
{"found", "HERE S\" Testing\" HERE S\" Test\" SEARCH . . . CR", "Should find substring", TEST_NORMAL, 0, 1, {0}},
{
"not_found", "HERE S\" Testing\" HERE S\" Xyz\" SEARCH . . . CR", "Should return false", TEST_NORMAL, 0,
1, {0}
},
{
"empty_pattern", "HERE S\" Test\" HERE 0 SEARCH . . . CR", "Should handle empty pattern", TEST_NORMAL, 0, 1, {0}
},
{"empty_string", "HERE 0 HERE S\" Test\" SEARCH . . . CR", "Should handle empty string", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"SCAN", {
{"basic", "HERE S\" Test,Data\" BL SCAN TYPE CR", "Should find space", TEST_NORMAL, 0, 1, {0}},
{"not_found", "HERE S\" TestData\" BL SCAN TYPE CR", "Should scan to end", TEST_NORMAL, 0, 1, {0}},
{"empty", "HERE 0 BL SCAN TYPE CR", "Should handle empty", TEST_NORMAL, 0, 1, {0}},
{"all_delims", "HERE S\" \" BL SCAN TYPE CR", "Should handle all delims", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"SKIP", {
{"basic", "HERE S\" Test\" BL SKIP TYPE CR", "Should skip spaces", TEST_NORMAL, 0, 1, {0}},
{"no_delims", "HERE S\" Test\" BL SKIP TYPE CR", "Should not skip", TEST_NORMAL, 0, 1, {0}},
{"empty", "HERE 0 BL SKIP TYPE CR", "Should handle empty", TEST_NORMAL, 0, 1, {0}},
{"all_delims", "HERE S\" \" BL SKIP TYPE CR", "Should skip all", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
4, {0}
},
{
"BLANK", {
{"basic", "HERE 5 BLANK HERE 5 TYPE CR", "Should fill with spaces", TEST_NORMAL, 0, 1, {0}},
{"zero", "HERE 0 BLANK HERE 0 TYPE CR", "Should handle zero count", TEST_NORMAL, 0, 1, {0}},
/* TODO: Bounds checking - memory subsystem doesn't yet enforce upper bounds */
/* {"bounds", "HERE 2000000 BLANK", "Should check bounds", TEST_ERROR_CASE, 1, 1}, */
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"S\"", {
{"interpret_len", "S\" hello\" . CR", "Should print: 5 (length)", TEST_NORMAL, 0, 1, {0}},
{"interpret_type", "S\" hello\" TYPE CR", "Should print: hello", TEST_NORMAL, 0, 1, {0}},
{"empty", "S\" \" . CR", "Should print: 0", TEST_NORMAL, 0, 1, {0}},
{"compile_type", ": TSQ S\" world\" TYPE CR ; TSQ", "Should print: world", TEST_NORMAL, 0, 1, {0}},
{"compile_len", ": TSQ2 S\" forth\" SWAP DROP . CR ; TSQ2", "Should print: 5", TEST_NORMAL, 0, 1, {0}},
{"compile_twice", ": TSQ3 S\" ab\" TYPE S\" cd\" TYPE CR ; TSQ3", "Should print: abcd", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
6, {0}
},
{
"BL", {
{"value", "BL . CR", "Should print: 32", TEST_NORMAL, 0, 1, {0}},
{"as_char", "BL EMIT CR", "Should emit a space", TEST_NORMAL, 0, 1, {0}},
{"in_scan", "HERE S\" a b\" BL SCAN SWAP DROP . CR", "Should find space at offset 1", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"SOURCE", {
{"returns_pair", "SOURCE SWAP DROP 0< NOT . CR", "Should return non-negative length", TEST_NORMAL, 0, 1, {0}},
{"has_addr", "SOURCE DROP 0<> . CR", "Should return non-null address", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
">IN", {
{"initial", ">IN @ . CR", "Should return input offset", TEST_NORMAL, 0, 1, {0}},
{"advances", ": TWIN >IN @ >IN @ - . CR ; TWIN", "Should print: 0 (no advance inside compiled word)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all string manipulation word tests
*
* @details Runs test suites for FORTH string operations including COUNT, -TRAILING,
* CMOVE, CMOVE>, COMPARE, SEARCH, SCAN, SKIP, and BLANK
*
* @param vm Pointer to the Forth virtual machine instance
*/
void run_string_words_tests(VM *vm) {
log_message(LOG_INFO, "Running String Words Tests (Module 11)...");
for (int i = 0; string_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &string_word_suites[i]);
}
print_module_summary("String Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/system_words_test.c
+133
View File
@@ -0,0 +1,133 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/**
* @brief Test suite definitions for system control words
* @details Contains test cases for each system word including normal operations
* and error conditions
*/
static WordTestSuite system_word_suites[] = {
{
"QUIT", {
{"basic", "QUIT", "Should reset stacks and state", TEST_NORMAL, 0, 0, {0}}, // Interactive
{"in_definition", ": BAD-WORD QUIT ;", "Should prevent compilation", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
2, {0}
},
{
"ABORT", {
{"basic", "ABORT", "Should clear stacks and return to QUIT", TEST_NORMAL, 0, 1, {0}},
{"with_data", "1 2 3 ABORT DEPTH . CR", "Should clear stack", TEST_NORMAL, 0, 1, {0}},
{
"in_definition_runtime", ": BAD-WORD ABORT ; 123 BAD-WORD DEPTH . CR",
"ABORT may appear in a definition; when executed it clears both stacks", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"ABORT\"", {
{
"condition_true", "-1 ABORT\" Error\"", "Should abort with message (no error; stacks cleared to QUIT)",
TEST_NORMAL, 0, 1, {0}
},
{"condition_false", "0 ABORT\" Error\"", "Should not abort", TEST_NORMAL, 0, 1, {0}},
{"empty_stack", "ABORT\"", "Should cause stack underflow", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"BYE", {
{"basic", "BYE", "Should exit cleanly", TEST_NORMAL, 0, 0, {0}}, // Can't really test
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"COLD", {
{"basic", "COLD", "Should reset system", TEST_NORMAL, 0, 0, {0}}, // Dangerous to test
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
{
"WARM", {
{"basic", "WARM", "Should soft reset", TEST_NORMAL, 0, 0, {0}}, // Dangerous to test
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
1, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/**
* @brief Executes all system word tests
* @details Runs test suites for FORTH system control operations including QUIT,
* ABORT, ABORT", BYE, COLD, and WARM. Some tests are marked as unimplemented
* due to their system-level effects
*
* @param vm Pointer to the Forth virtual machine instance
*/
void run_system_words_tests(VM *vm) {
log_message(LOG_INFO, "Running System Words Tests (Module 18)...");
log_message(LOG_WARN, "Some system tests marked as unimplemented due to system-level effects");
for (int i = 0; system_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &system_word_suites[i]);
}
print_module_summary("System Words", 0, 0, 0, 0);
}
v3/src/test_runner/modules/vocabulary_words_test.c
+163
View File
@@ -0,0 +1,163 @@
/*
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/test_runner.h"
#include "../include/test_common.h"
/** @brief Test suites for vocabulary-related FORTH words (Module 15)
* @details Contains test cases for each vocabulary word, including normal operations
* and error cases. Each suite tests specific functionality of the vocabulary system.
*/
static WordTestSuite vocabulary_word_suites[] = {
{
"VOCABULARY", {
/* Basic functionality */
{"basic", "VOCABULARY TEST-VOC1 TEST-VOC1 DEFINITIONS", "Should create vocabulary", TEST_NORMAL, 0, 1, {0}},
{
"create_and_switch", "VOCABULARY MYVOC MYVOC DEFINITIONS CONTEXT @ . CR", "Should create and switch",
TEST_NORMAL, 0, 1, {0}
},
/* Word isolation */
{
"word_isolation", "VOCABULARY ISOLATED ISOLATED DEFINITIONS : ISOWORD 99 ; FORTH DEFINITIONS",
"Should create word in isolated vocab", TEST_NORMAL, 0, 1, {0}
},
{
"cross_vocab_access", "VOCABULARY V1 V1 DEFINITIONS : V1WORD 11 ; FORTH V1WORD . CR",
"Should access word across vocabs", TEST_NORMAL, 0, 1, {0}
},
/* Multiple vocabularies */
{
"multiple_vocabs", "VOCABULARY VA VOCABULARY VB VOCABULARY VC VA DEFINITIONS",
"Should create multiple vocabs", TEST_NORMAL, 0, 1, {0}
},
/* Error cases */
{
"duplicate", "VOCABULARY TESTVOC VOCABULARY TESTVOC", "Should handle duplicate", TEST_ERROR_CASE, 1,
1, {0}
},
{"empty_name", "VOCABULARY", "Should handle empty name", TEST_ERROR_CASE, 1, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
7, {0}
},
{
"FORTH", {
{"basic", "FORTH DEFINITIONS", "Should select FORTH vocab", TEST_NORMAL, 0, 1, {0}},
{"persistence", "FORTH : TEST1 42 ; TEST1 . CR", "Should find word in FORTH", TEST_NORMAL, 0, 1, {0}},
{"from_other", "VOCABULARY OTHER-VOC OTHER-VOC FORTH", "Should return to FORTH", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"DEFINITIONS", {
{"basic", "FORTH DEFINITIONS", "Should set current vocabulary", TEST_NORMAL, 0, 1, {0}},
{"new_vocab", "VOCABULARY TEST-VOC6 TEST-VOC6 DEFINITIONS", "Should set new current", TEST_NORMAL, 0, 1, {0}},
{
"word_creation", "VOCABULARY TEST-VOC7 TEST-VOC7 DEFINITIONS : TEST2 43 ;",
"Should create in correct vocab", TEST_NORMAL, 0, 1, {0}
},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"CONTEXT", {
{"basic", "CONTEXT @ . CR", "Should show current context", TEST_NORMAL, 0, 1, {0}},
{"modify", "CONTEXT @ 1+ CONTEXT !", "Should allow modification (impl-defined effect)", TEST_NORMAL, 0, 1, {0}},
{"initial", "FORTH CONTEXT @ . CR", "Should show FORTH vocab", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"CURRENT", {
{"basic", "CURRENT @ . CR", "Should show current vocab", TEST_NORMAL, 0, 1, {0}},
{
"after_def", "VOCABULARY TEST-VOC8 TEST-VOC8 DEFINITIONS CURRENT @ . CR", "Should show new vocab",
TEST_NORMAL, 0, 1, {0}
},
{"protect", "CURRENT @ 1+ CURRENT !", "Should allow modification (impl-defined effect)", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
{
"ORDER", {
{"basic", "ORDER", "Should list search order", TEST_NORMAL, 0, 1, {0}},
{
"multiple", "VOCABULARY TEST-VOC9 TEST-VOC9 DEFINITIONS ORDER", "Should show all vocabs", TEST_NORMAL, 0, 1, {0}
},
{"after_forth", "TEST-VOC9 FORTH ORDER", "Should show FORTH only", TEST_NORMAL, 0, 1, {0}},
{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}
},
3, {0}
},
/* End marker */
{NULL, {{NULL, NULL, NULL, TEST_NORMAL, 0, 0, {0}}}, 0, {0}}
};
/** @brief Executes all vocabulary word test suites
* @param vm Pointer to the Forth virtual machine instance
* @details Runs through all vocabulary-related test suites, executing each test case
* and logging the results_run_01_2025_12_08. Tests vocabulary creation, selection, and manipulation.
*/
void run_vocabulary_words_tests(VM *vm) {
log_message(LOG_INFO, "Running Vocabulary Words Tests (Module 15)...");
for (int i = 0; vocabulary_word_suites[i].word_name != NULL; i++) {
log_message(LOG_TEST, "▶ Testing module: %s", __FILE__);
run_test_suite(vm, &vocabulary_word_suites[i]);
}
print_module_summary("Vocabulary Words", 0, 0, 0, 0);
}
v3/src/test_runner/test_common.c
+510
View File
@@ -0,0 +1,510 @@
/*
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/vm.h"
#include "../../include/vm_debug.h"
#include "include/test_common.h"
#include "include/test_contracts.h"
#include "../../include/log.h"
#include "test_runner.h"
#ifdef __STARKERNEL__
#include "starkernel/hal/hal.h"
#define test_fatal_exit() sk_hal_panic("test failure - fail fast")
#else
#include <stdio.h>
#include <stdlib.h>
#define test_fatal_exit() exit(1)
#endif
/**
* @brief Global flag to control test execution behavior
* @details When set to non-zero, causes test runner to exit immediately on first failure
*/
int fail_fast = 0;
/* ---------- debug helpers (dump on fatal and exit) ---------- */
/**
* @brief Dumps VM state and terminates execution
* @param vm Pointer to VM instance
* @param reason String describing the failure reason
* @param file Source file where failure occurred
* @param line Line number where failure occurred
*/
static void dump_and_die(VM* vm, const char* reason, const char* file, int line)
{
log_message(LOG_ERROR, "[TEST-RUNNER] abort @ %s:%d (%s)",
file, line, reason ? reason : "no-reason");
vm_debug_dump_state(vm, reason ? reason : "test-failure");
test_fatal_exit();
}
/* Convenience macro so call sites get file:line automatically */
#define DIE(vm, why) dump_and_die((vm), (why), __FILE__, __LINE__)
/* Single gate used by fail-fast paths */
/**
* @brief Handles test failure and exits
* @param vm Pointer to VM instance
* @param module Name of the test module
* @param case_name Name of the test case
* @param input Test input that caused the failure
* @param reason Description of failure reason
*/
static void fail_and_exit(VM* vm,
const char* module,
const char* case_name,
const char* input,
const char* reason)
{
if (module && *module && case_name && *case_name)
{
log_message(LOG_ERROR, "[TEST-RUNNER] FAIL in %s.%s", module, case_name);
}
else if (module && *module)
{
log_message(LOG_ERROR, "[TEST-RUNNER] FAIL in %s", module);
}
if (input && *input)
{
log_message(LOG_ERROR, "[TEST-RUNNER] Input: %s", input);
}
if (reason && *reason)
{
log_message(LOG_ERROR, "[TEST-RUNNER] Reason: %s", reason);
}
/* Dump VM state at point-of-failure and exit */
DIE(vm, reason ? reason : "assertion failed");
}
/* ---------- VM state save/restore ---------- */
/**
* @brief Saves current VM state
* @param vm Pointer to VM instance
* @param dsp Pointer to store data stack pointer
* @param rsp Pointer to store return stack pointer
* @param error Pointer to store error state
* @param mode Pointer to store VM mode
*/
void save_vm_state(VM* vm, int* dsp, int* rsp, int* error, vm_mode_t* mode)
{
*dsp = vm->dsp;
*rsp = vm->rsp;
*error = vm->error;
*mode = vm->mode;
}
/**
* @brief Restores previously saved VM state
* @param vm Pointer to VM instance
* @param dsp Data stack pointer to restore
* @param rsp Return stack pointer to restore
* @param error Error state to restore
* @param mode VM mode to restore
*/
void restore_vm_state(VM* vm, int dsp, int rsp, int error, vm_mode_t mode)
{
/* Restore to the caller-supplied saved state -- every real caller
* (acl_words_test.c, this file's own save/restore pairs) captures
* dsp/rsp/error/mode before running a test specifically so it can be
* put back here. This previously ignored all four parameters and
* hard-reset to a fixed baseline instead, silently not restoring
* anything callers actually saved. */
vm->dsp = dsp;
vm->rsp = rsp;
vm->error = error;
vm->mode = mode;
/* Clear control flow flags to prevent stale state between tests */
vm->exit_colon = 0;
vm->abort_requested = 0;
/* Clear compilation state in case test left system in compile mode */
vm->compiling_word = NULL;
vm->current_executing_entry = NULL;
}
/* ---------- Assertions ---------- */
/**
* @brief Verifies VM stack depth matches expected value
* @param vm Pointer to VM instance
* @param expected_depth Expected stack depth
* @return 1 if assertion passes, 0 if it fails
*/
int assert_stack_depth(VM* vm, int expected_depth)
{
if (vm->dsp == expected_depth)
{
return 1;
}
log_message(LOG_ERROR, "Stack depth mismatch: expected %d, got %d", expected_depth, vm->dsp);
return 0;
}
/**
* @brief Verifies top value on VM stack matches expected value
* @param vm Pointer to VM instance
* @param expected_value Expected value on top of stack
* @return 1 if assertion passes, 0 if it fails
*/
int assert_stack_top(VM* vm, int expected_value)
{
if (vm->dsp < 1)
{
log_message(LOG_ERROR, "Stack underflow when checking top value");
return 0;
}
if (vm->data_stack[vm->dsp - 1] == expected_value)
{
return 1;
}
log_message(LOG_ERROR, "Stack top mismatch: expected %d, got %d",
expected_value, vm->data_stack[vm->dsp - 1]);
return 0;
}
/**
* @brief Verifies VM error state matches expectation
* @param vm Pointer to VM instance
* @param should_have_error Expected error state (1 for error, 0 for no error)
* @return 1 if assertion passes, 0 if it fails
*/
int assert_vm_error(VM* vm, int should_have_error)
{
int has_error = (vm->error != 0);
if (has_error == should_have_error)
{
return 1;
}
if (should_have_error)
{
log_message(LOG_ERROR, "Expected VM error but none occurred");
}
else
{
log_message(LOG_ERROR, "Unexpected VM error: %d", vm->error);
}
return 0;
}
/* ---------- Test execution ---------- */
/* Run a single test case */
/**
* @brief Executes a single test case
* @param vm Pointer to VM instance
* @param word_name Name of the word being tested
* @param test Pointer to test case definition
* @return Test result (PASS, FAIL, SKIP, or ERROR)
*/
TestResult run_single_test(VM* vm, const char* word_name, const TestCase* test)
{
if (!test->implemented)
{
log_test_result(word_name, TEST_SKIP);
return TEST_SKIP;
}
/* Save VM state */
int saved_dsp, saved_rsp, saved_error;
vm_mode_t saved_mode;
save_vm_state(vm, &saved_dsp, &saved_rsp, &saved_error, &saved_mode);
/* Clear error state */
vm->error = 0;
log_message(LOG_TEST, " Running %s.%s: %s", word_name, test->name, test->input);
/* Execute the test */
vm_interpret(vm, test->input);
/* Check results */
TestResult result;
if (test->should_error)
{
if (vm->error != 0)
{
result = TEST_PASS;
log_message(LOG_TEST, " Expected error occurred");
}
else
{
result = TEST_FAIL;
log_message(LOG_ERROR, " Expected error but none occurred");
}
}
else
{
if (vm->error != 0)
{
result = TEST_FAIL;
log_message(LOG_ERROR, " Unexpected VM error: %d", vm->error);
}
else
{
result = TEST_PASS;
log_message(LOG_TEST, " Test passed");
}
}
log_test_result(word_name, result);
if (result == TEST_PASS)
{
log_message(LOG_TEST, " Expected: %s", test->expected);
}
/* Restore VM nightly */
restore_vm_state(vm, saved_dsp, saved_rsp, saved_error, saved_mode);
if (result == TEST_FAIL)
{
log_message(LOG_ERROR, "Test failed: %s.%s", word_name, test->name);
log_message(LOG_ERROR, "Input: %s", test->input);
log_message(LOG_ERROR, "Expected: %s", test->expected);
if (fail_fast != 0)
{
/* Fail fast: dump and exit with real names from this scope */
fail_and_exit(vm, word_name, test->name, test->input, "assertion failed");
}
}
return result;
}
/* Run a complete test suite for one word */
/**
* @brief Executes a complete test suite for a Forth word
* @param vm Pointer to VM instance
* @param suite Pointer to test suite definition
*/
void run_test_suite(VM* vm, const WordTestSuite* suite)
{
log_message(LOG_TEST, "Testing word: %s", suite->word_name);
log_message(LOG_TEST, "------------------------");
/* Save dictionary state before test suite */
DictEntry* saved_latest;
size_t saved_here;
save_dict_state(vm, &saved_latest, &saved_here);
int suite_pass = 0;
int suite_fail = 0;
int suite_skip = 0;
int suite_error = 0;
for (int j = 0; j < suite->test_count && suite->tests[j].name != NULL; j++)
{
const TestCase* test = &suite->tests[j];
if (!test->implemented)
{
suite_skip++;
continue;
}
TestResult result = run_single_test(vm, suite->word_name, test);
switch (result)
{
case TEST_PASS: suite_pass++;
break;
case TEST_FAIL: suite_fail++;
break;
case TEST_SKIP: suite_skip++;
break;
case TEST_ERROR: suite_error++;
break;
}
}
/* Restore dictionary state after test suite to remove test-created words */
restore_dict_state(vm, saved_latest, saved_here);
test_stats_accumulate(suite_pass + suite_fail + suite_skip + suite_error,
suite_pass, suite_fail, suite_skip, suite_error);
log_message(LOG_TEST, " %s: %d passed, %d failed, %d stubs, %d errors",
suite->word_name, suite_pass, suite_fail, suite_skip, suite_error);
}
/* ============================================================================
* run_test_suite_m — contract-aware suite runner
* ============================================================================ */
/**
* @brief Resolves the effective contract for a test case.
*
* First non-NONE source wins: per-test > per-suite > module.
*/
static WordContract resolve_contract(WordContract test_c,
WordContract suite_c,
WordContract module_c)
{
if (test_c.flags) return test_c;
if (suite_c.flags) return suite_c;
return module_c;
}
void run_test_suite_m(VM *vm, const WordTestSuite *suite, WordContract module_contract)
{
log_message(LOG_TEST, "Testing word: %s", suite->word_name);
log_message(LOG_TEST, "------------------------");
DictEntry* saved_latest;
size_t saved_here;
save_dict_state(vm, &saved_latest, &saved_here);
int suite_pass = 0;
int suite_fail = 0;
int suite_skip = 0;
int suite_error = 0;
for (int j = 0; j < suite->test_count && suite->tests[j].name != NULL; j++)
{
const TestCase* test = &suite->tests[j];
if (!test->implemented)
{
suite_skip++;
continue;
}
TestResult result = run_single_test(vm, suite->word_name, test);
switch (result)
{
case TEST_PASS:
suite_pass++;
/* A4' contract check for passing non-error tests */
if (result == TEST_PASS && test->type != TEST_ERROR_CASE)
{
WordContract eff = resolve_contract(test->contract,
suite->suite_contract,
module_contract);
if (eff.flags & CONTRACT_PHYSICS_TRANSPARENT)
{
int ok = check_physics_transparent(vm, suite->word_name,
test->input,
test->should_error,
test->implemented,
eff.fuzz_rounds);
if (!ok)
{
/* Demote to fail: contract violation is a test failure */
suite_pass--;
suite_fail++;
}
}
}
break;
case TEST_FAIL: suite_fail++; break;
case TEST_SKIP: suite_skip++; break;
case TEST_ERROR: suite_error++; break;
}
}
restore_dict_state(vm, saved_latest, saved_here);
test_stats_accumulate(suite_pass + suite_fail + suite_skip + suite_error,
suite_pass, suite_fail, suite_skip, suite_error);
log_message(LOG_TEST, " %s: %d passed, %d failed, %d stubs, %d errors",
suite->word_name, suite_pass, suite_fail, suite_skip, suite_error);
}
/* Print module summary */
/**
* @brief Prints test module execution summary
* @param module_name Name of the test module
* @param pass Number of passed tests
* @param fail Number of failed tests
* @param skip Number of skipped tests
* @param error Number of tests with errors
*/
void print_module_summary(const char* module_name, int pass, int fail, int skip, int error)
{
log_message(LOG_TEST, "=== %s Summary: %d passed, %d failed, %d skipped, %d errors ===",
module_name, pass, fail, skip, error);
}
/* ---------- Dictionary State Management ---------- */
/**
* @brief Saves current dictionary state before test execution
* @param vm Pointer to VM instance
* @param latest Pointer to store latest dictionary entry
* @param here Pointer to store HERE pointer
* @details Captures dictionary state so tests can be cleaned up after execution
*/
void save_dict_state(VM* vm, DictEntry** latest, size_t* here)
{
*latest = vm->latest;
*here = vm->here;
}
/**
* @brief Restores dictionary state after test execution
* @param vm Pointer to VM instance
* @param latest Latest dictionary entry to restore
* @param here HERE pointer to restore
* @details Removes all words added during test by restoring dictionary pointers.
* This prevents test pollution of the dictionary and ensures each test
* starts with a clean slate.
*/
void restore_dict_state(VM* vm, DictEntry* latest, size_t here)
{
/* Restore dictionary pointers to state before test */
vm->latest = latest;
vm->here = here;
/* NOTE: We don't free memory here because the dictionary uses a contiguous
* memory region. The memory is still allocated but unreachable. This is
* safe because tests run in a controlled environment and memory is reclaimed
* when the VM terminates. For long-running test suites, consider periodically
* reinitializing the VM. */
}
v3/src/test_runner/test_contracts.c
+356
View File
@@ -0,0 +1,356 @@
/*
StarForth — Steady-State Virtual Machine Runtime
Copyright (c) 2023–2025 Robert A. James
Licensed under the Starship License 1.0 (SL-1.0)
*/
/*
* test_contracts.c — Runtime witnesses for Isabelle/HOL axioms A1 and A4'.
*
* All contract checks are compiled away when CONTRACTS_ENABLED != 1 so that
* normal `make test` builds carry zero overhead.
*/
#include "test_contracts.h"
#include "log.h" /* log_message, LOG_ERROR, LOG_TEST */
#include "vm.h" /* VM, vm_interpret, vm_tick, ROLLING_WINDOW_SIZE */
#include <string.h> /* memcpy, memset, memcmp */
/* Global violation counter (defined here; declared extern in test_contracts.h) */
int global_contract_violations = 0;
/*
* Accessor functions — same-TU direct access avoids R_X86_64_REX_GOTPCRELX
* double-dereference in -fPIC PE builds where GOTPCRELX is not relaxed to LEA.
*/
/**
* @brief Return the current count of accumulated contract violations.
*
* Reads @c global_contract_violations directly; same-TU access avoids
* GOT double-dereference in @c -fPIC PE32+ builds where
* @c R_X86_64_REX_GOTPCRELX is not relaxed to a LEA instruction.
*
* @return Number of contract violations recorded since last reset.
*/
int contract_get_violation_count(void) { return global_contract_violations; }
/**
* @brief Reset the contract violation counter to zero.
*
* Call before a fresh round of contract checks so that counts from
* earlier test phases do not accumulate across module boundaries.
*/
void contract_reset_violation_count(void) { global_contract_violations = 0; }
/* ============================================================================
* xorshift64 RNG — deterministic, seeded per-round so each perturbation
* produces a distinct physics state.
* ============================================================================ */
static uint64_t rng_state = 0xDEADBEEFCAFEBABEULL;
/**
* @brief Generate the next pseudo-random 64-bit value via xorshift64.
*
* Uses the global @c rng_state. The xorshift64 parameters (13, 7, 17)
* produce a full-period sequence over all non-zero 64-bit states.
* Caller must seed via @c rng_seed() before starting a new fuzz round
* to ensure different perturbation sequences across rounds.
*
* @return Next pseudo-random 64-bit integer.
*/
static uint64_t contract_rand(void) {
uint64_t x = rng_state;
x ^= x << 13;
x ^= x >> 7;
x ^= x << 17;
rng_state = x;
return x;
}
/**
* @brief Seed the RNG for a given fuzz round.
*
* Derives a deterministic seed from the round index mixed with a
* Fibonacci multiplier (@c 0x9E3779B97F4A7C15) so each round produces
* a distinct, reproducible perturbation sequence regardless of how many
* rounds have previously run.
*
* @param round Zero-based fuzz round index.
*/
static void rng_seed(int round) {
rng_state = 0xDEADBEEFCAFEBABEULL ^ ((uint64_t)(unsigned)round * 0x9E3779B97F4A7C15ULL);
}
/* ============================================================================
* Exec-domain capture and comparison
* ============================================================================ */
/**
* @brief Snapshot the execution-domain fields of a VM into an @c ExecResult.
*
* Captures @c dsp, @c rsp, @c error, and the live portion of the data
* stack (indices 0 … dsp−1). The remainder of @c r->stack is zeroed for
* deterministic @c memcmp() comparisons in @c exec_results_equal().
*
* Only execution-domain fields are captured — physics scalars, heartbeat
* state, and rolling-window counters are deliberately excluded.
*
* @param vm VM instance to snapshot.
* @param r Output @c ExecResult struct to populate.
*/
void capture_exec_result(VM *vm, ExecResult *r) {
r->dsp = vm->dsp;
r->rsp = vm->rsp;
r->error = vm->error;
/* copy only the live portion; zero the rest for deterministic memcmp */
int depth = (vm->dsp > 0) ? vm->dsp : 0;
memcpy(r->stack, vm->data_stack, (size_t)depth * sizeof(cell_t));
if (depth < STACK_SIZE)
memset(&r->stack[depth], 0, (size_t)(STACK_SIZE - depth) * sizeof(cell_t));
}
/**
* @brief Compare two @c ExecResult snapshots for execution-domain equality.
*
* Returns 1 only if @c dsp, @c rsp, @c error, and the live stack contents
* are all identical. Stack comparison uses @c memcmp() over the live
* portion (0 … dsp−1 cells); the zeroed tail guarantees no false
* positives from uninitialised padding.
*
* @param a First snapshot.
* @param b Second snapshot.
* @return 1 if execution-domain is identical, 0 if any field differs.
*/
int exec_results_equal(const ExecResult *a, const ExecResult *b) {
if (a->dsp != b->dsp) return 0;
if (a->rsp != b->rsp) return 0;
if (a->error != b->error) return 0;
int depth = (a->dsp > 0) ? a->dsp : 0;
return memcmp(a->stack, b->stack, (size_t)depth * sizeof(cell_t)) == 0;
}
/* ============================================================================
* Physics snapshot / restore / perturb
*
* These cover the key scalars touched by the seven feedback loops. A word
* that reads any of these will produce a different ExecResult after perturb,
* exposing a violation of A4'.
* ============================================================================ */
/**
* @brief Save the key physics scalars touched by the seven feedback loops.
*
* Captures the eight fields that @c perturb_physics() will randomise:
* @c decay_slope_q48, @c effective_window_size, @c tick_target_ns,
* the three heat percentile thresholds, @c prefetch_attempts, and
* @c total_executions. Used as a bracket pair with @c restore_physics()
* around each fuzz round so the VM returns to a known state.
*
* @param vm VM instance to snapshot.
* @param s Output @c PhysicsSnapshot to populate.
*/
void save_physics(VM *vm, PhysicsSnapshot *s) {
s->decay_slope_q48 = vm->decay_slope_q48;
s->eff_window_size = vm->rolling_window.effective_window_size;
s->tick_target_ns = vm->heartbeat.tick_target_ns;
s->heat_25th = vm->heat_threshold_25th;
s->heat_50th = vm->heat_threshold_50th;
s->heat_75th = vm->heat_threshold_75th;
s->prefetch_attempts = vm->pipeline_metrics.prefetch_attempts;
s->total_executions = vm->rolling_window.total_executions;
}
/**
* @brief Restore the physics scalars from a previously saved snapshot.
*
* Writes back the eight fields saved by @c save_physics(), undoing any
* perturbations made by @c perturb_physics(). Called at the end of each
* fuzz round and after the full @c check_physics_transparent() loop so
* the VM state is clean for the next contract check.
*
* @param vm VM instance to restore.
* @param s Source @c PhysicsSnapshot to restore from.
*/
void restore_physics(VM *vm, const PhysicsSnapshot *s) {
vm->decay_slope_q48 = s->decay_slope_q48;
vm->rolling_window.effective_window_size = s->eff_window_size;
vm->heartbeat.tick_target_ns = s->tick_target_ns;
vm->heat_threshold_25th = s->heat_25th;
vm->heat_threshold_50th = s->heat_50th;
vm->heat_threshold_75th = s->heat_75th;
vm->pipeline_metrics.prefetch_attempts = s->prefetch_attempts;
vm->rolling_window.total_executions = s->total_executions;
}
/**
* @brief Randomly perturb key physics scalars to expose A4' violations.
*
* Seeds the RNG via @c rng_seed(@p round) for deterministic but distinct
* perturbations per round, then overwrites the eight tracked physics
* fields with random values that still satisfy their well-formedness
* invariants:
*
* - @c decay_slope_q48: LSB forced to 1 (must be > 0 per @c slope_wf)
* - @c effective_window_size: [1, ROLLING_WINDOW_SIZE] (never 0)
* - @c tick_target_ns: LSB forced to 1 (must be > 0 per @c hb_state_wf)
* - Heat thresholds: arbitrary positive values (no strict invariant)
* - @c prefetch_attempts / @c total_executions: arbitrary counts
*
* After perturbation, running the same FORTH input must produce an
* identical @c ExecResult; divergence is an A4' violation.
*
* @param vm VM instance to perturb.
* @param round Fuzz round index (used to seed the RNG).
*/
void perturb_physics(VM *vm, int round) {
rng_seed(round);
/* decay_slope_q48: must be > 0 per slope_wf */
vm->decay_slope_q48 = contract_rand() | 1ULL;
/* effective_window_size: must be in [1, ROLLING_WINDOW_SIZE] */
uint64_t w = contract_rand() % (uint64_t)ROLLING_WINDOW_SIZE;
vm->rolling_window.effective_window_size = (uint32_t)(w == 0 ? 1 : w);
/* tick_target_ns: must be > 0 per hb_state_wf */
vm->heartbeat.tick_target_ns = contract_rand() | 1ULL;
/* heat thresholds: arbitrary signed values */
vm->heat_threshold_25th = (cell_t)(contract_rand() & 0x7FFF);
vm->heat_threshold_50th = (cell_t)(contract_rand() & 0xFFFF);
vm->heat_threshold_75th = (cell_t)(contract_rand() & 0x1FFFF);
/* pipeline and window counters */
vm->pipeline_metrics.prefetch_attempts = contract_rand();
vm->rolling_window.total_executions = contract_rand();
}
/* ============================================================================
* A4' contract check
* ============================================================================ */
/**
* @brief A4' contract check — verify a word is transparent to physics state.
*
* Axiom A4' (physics transparency): a FORTH word's execution-domain
* result (@c ExecResult) must be identical regardless of the values of
* the seven physics feedback-loop scalars.
*
* Protocol:
* 1. Run @p input with current (unperturbed) physics; capture baseline.
* 2. For each of @p fuzz_rounds rounds: seed RNG, perturb physics,
* re-run @p input, capture result, compare to baseline.
* 3. On divergence, log the violation and increment
* @c global_contract_violations.
* 4. Always restore original physics state before returning.
*
* Error-expected tests (@p should_error) and unimplemented words
* (@p implemented == 0) are skipped: exec-equivalent divergence is
* legitimate for error paths.
*
* @param vm VM instance.
* @param word_name Human-readable word name for diagnostic messages.
* @param input FORTH source string to execute (same each round).
* @param should_error Non-zero if the test is expected to raise an error.
* @param implemented Non-zero if the word is implemented and should be checked.
* @param fuzz_rounds Number of perturbation rounds; 0 → CONTRACT_DEFAULT_FUZZ_ROUNDS.
* @return 1 if all rounds passed (or test skipped), 0 on any violation.
*/
int check_physics_transparent(VM *vm, const char *word_name,
const char *input,
int should_error, int implemented,
int fuzz_rounds) {
/* Skip error-expected tests: exec-equiv may legitimately differ */
if (!implemented || should_error) return 1;
int rounds = (fuzz_rounds > 0) ? fuzz_rounds : CONTRACT_DEFAULT_FUZZ_ROUNDS;
/* --- Baseline run with current (unperturbed) physics --- */
vm->error = 0;
vm->dsp = -1;
vm->rsp = -1;
vm->exit_colon = 0;
vm->abort_requested = 0;
vm_interpret(vm, input);
ExecResult baseline;
capture_exec_result(vm, &baseline);
PhysicsSnapshot saved;
save_physics(vm, &saved);
int ok = 1;
for (int r = 0; r < rounds && ok; r++) {
perturb_physics(vm, r);
vm->error = 0;
vm->dsp = -1;
vm->rsp = -1;
vm->exit_colon = 0;
vm->abort_requested = 0;
vm_interpret(vm, input);
ExecResult fuzzed;
capture_exec_result(vm, &fuzzed);
if (!exec_results_equal(&baseline, &fuzzed)) {
log_message(LOG_ERROR,
"[A4' CONTRACT] VIOLATION: %s '%s' result changed under physics perturbation (round %d)",
word_name, input, r);
log_message(LOG_ERROR,
" baseline dsp=%d fuzzed dsp=%d", baseline.dsp, fuzzed.dsp);
ok = 0;
global_contract_violations++;
}
vm->dsp = -1;
vm->rsp = -1;
vm->error = 0;
}
restore_physics(vm, &saved);
vm->dsp = -1;
vm->rsp = -1;
vm->error = 0;
return ok;
}
/* ============================================================================
* A1 contract check
* ============================================================================ */
/**
* @brief A1 contract check — verify @c vm_tick() does not modify the execution domain.
*
* Axiom A1 (heartbeat isolation): the background heartbeat tick must never
* alter stacks, error state, or any other execution-domain field observable
* by FORTH words. This function captures an @c ExecResult before and after
* one @c vm_tick() call and compares them with @c exec_results_equal().
*
* On violation, logs @c [A1 CONTRACT] VIOLATION with before/after dsp and
* rsp values, and increments @c global_contract_violations.
*
* @param vm VM instance; stacks and error state must already be in a known
* reference state before calling.
* @return 1 if the heartbeat left the execution domain unchanged, 0 on violation.
*/
int assert_heartbeat_safe(VM *vm) {
ExecResult before, after;
capture_exec_result(vm, &before);
vm_tick(vm);
capture_exec_result(vm, &after);
if (!exec_results_equal(&before, &after)) {
log_message(LOG_ERROR,
"[A1 CONTRACT] VIOLATION: vm_tick() modified exec-equiv fields");
log_message(LOG_ERROR,
" dsp before=%d after=%d rsp before=%d after=%d",
before.dsp, after.dsp, before.rsp, after.rsp);
global_contract_violations++;
return 0;
}
return 1;
}
v3/src/test_runner/test_runner.c
+272
View File
@@ -0,0 +1,272 @@
/*
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/test_runner.h"
#include "include/test_contracts.h"
#include "../../include/log.h"
#include <stdint.h>
#ifdef __STARKERNEL__
#include "platform_time.h"
/* Kernel uses sf_monotonic_ns() for timing */
/* strcmp provided by shim.c */
extern int strcmp(const char *a, const char *b);
#else
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#endif
/** @brief Global statistics for test execution */
#ifdef __STARKERNEL__
/* Ensure visibility for GOT-based access with -fPIC -fvisibility=hidden */
__attribute__((visibility("default")))
#endif
TestStats global_test_stats = {0, 0, 0, 0, 0};
/*
* Same-TU accessor — avoids R_X86_64_REX_GOTPCRELX double-dereference in
* -fPIC PE builds where struct access generates GOT-indirect code that the
* PE linker does not relax.
*/
void test_stats_accumulate(int tests, int pass, int fail, int skip, int error)
{
global_test_stats.total_tests += tests;
global_test_stats.total_pass += pass;
global_test_stats.total_fail += fail;
global_test_stats.total_skip += skip;
global_test_stats.total_error += error;
}
/** @brief Flag indicating if benchmark mode is enabled */
static int benchmark_mode = 0;
/** @brief Number of iterations for benchmark tests */
static int benchmark_iterations = 1000;
/**
* @brief Get current time in nanoseconds
*
* Uses platform-specific timing: sf_monotonic_ns() on kernel, clock() on hosted.
*
* @return Current time in nanoseconds, or 0 on error
*/
static uint64_t get_time_ns(void) {
#ifdef __STARKERNEL__
return sf_monotonic_ns();
#else
clock_t t = clock();
if (t == (clock_t)(-1)) {
return 0; /* Error case */
}
/* Convert to nanoseconds: (clock_ticks / CLOCKS_PER_SEC) * 1,000,000,000 */
return (uint64_t)((double) t / CLOCKS_PER_SEC * 1000000000.0);
#endif
}
/* Test modules in POST (Power-On Self Test) order:
* 1. Unit tests (foundational math/algorithms) run FIRST
* 2. Dictionary tests (FORTH word validation) run after POST passes
*/
static TestModule test_modules[] = {
/* === Dictionary Tests: FORTH-79 Word Validation === */
{"Stack Words", NULL, 0, run_stack_words_tests}, /* Module 5 */
{"Return Stack Words", NULL, 0, run_return_stack_words_tests}, /* Module 6 */
{"Memory Words", NULL, 0, run_memory_words_tests}, /* Module 7 */
{"Arithmetic Words", NULL, 0, run_arithmetic_words_tests}, /* Module 8 */
{"Logical Words", NULL, 0, run_logical_words_tests}, /* Module 9 */
{"Mixed Arithmetic Words", NULL, 0, run_mixed_arithmetic_words_tests}, /* Module 10 */
{"Double Words", NULL, 0, run_double_words_tests}, /* Module 11 */
{"Format Words", NULL, 0, run_format_words_tests}, /* Module 12 */
{"String Words", NULL, 0, run_string_words_tests}, /* Module 13 */
{"I/O Words", NULL, 0, run_io_words_tests}, /* Module 14 */
{"Block Words", NULL, 0, run_block_words_tests}, /* Module 15 */
{"Dictionary Words", NULL, 0, run_dictionary_words_tests}, /* Module 16 */
{"Dictionary Manipulation Words", NULL, 0, run_dictionary_manipulation_words_tests}, /* Module 17 */
{"Vocabulary Words", NULL, 0, run_vocabulary_words_tests}, /* Module 18 */
{"System Words", NULL, 0, run_system_words_tests}, /* Module 19 */
{"Defining Words", NULL, 0, run_defining_words_tests}, /* Module 20 */
{"Control Words", NULL, 0, run_control_words_tests}, /* Module 21 */
{"StarForth Words", NULL, 0, run_starforth_words_tests}, /* Module 22 */
{"ACL Words", NULL, 0, run_acl_words_tests}, /* Module 23: Word-Level ACL System */
{"Mama FORTH Words", NULL, 0, run_mama_forth_words_tests}, /* Module 24: Capsule System M7.1 */
{"Q48.16 Words", NULL, 0, run_q48_words_tests}, /* Module 25: Q48.16 Fixed-Point Arithmetic */
{"Inference Engine Words", NULL, 0, run_inference_words_tests}, /* Module 26: SSM Inference (proof-covered subset) */
{"Physics Freeze Words", NULL, 0, run_physics_freeze_words_tests}, /* Module 27: Physics Freeze (proof-covered subset) */
{NULL, NULL, 0, NULL} /* End marker */
};
/**
* @brief Enable benchmark mode for test execution
*
* @param iterations Number of times each test should be repeated
*/
void enable_benchmark_mode(int iterations) {
benchmark_mode = 1;
benchmark_iterations = iterations;
log_message(LOG_INFO, "Benchmark mode enabled: %d iterations per module", iterations);
}
/**
* @brief Run all test modules with optional benchmarking
*
* Executes all registered test modules sequentially, collecting statistics
* and/or benchmark data depending on the current mode.
*
* @param vm Pointer to the Forth virtual machine instance
*/
void run_all_tests(VM *vm) {
log_message(LOG_INFO, "Starting comprehensive FORTH-79 modular test suite...");
log_message(LOG_INFO, "==============================================");
/* Reset global statistics */
global_test_stats.total_tests = 0;
global_test_stats.total_pass = 0;
global_test_stats.total_fail = 0;
global_test_stats.total_skip = 0;
global_test_stats.total_error = 0;
contract_reset_violation_count();
/* Run each test module */
for (int i = 0; test_modules[i].module_name != NULL; i++) {
TestModule const*module = &test_modules[i];
log_message(LOG_INFO, "\n=== Testing Module: %s ===", module->module_name);
if (module->run_module_tests != NULL) {
module->run_module_tests(vm);
} else {
log_message(LOG_WARN, "Module %s: No tests implemented yet", module->module_name);
}
}
/* Print test summary */
log_message(LOG_INFO, "FINAL TEST SUMMARY:");
log_message(LOG_INFO, " Total tests run: %d", global_test_stats.total_tests);
log_message(LOG_INFO, " Passed: %d", global_test_stats.total_pass);
log_message(LOG_INFO, " Failed: %d", global_test_stats.total_fail);
log_message(LOG_INFO, " Stubs (not yet implemented): %d", global_test_stats.total_skip);
log_message(LOG_INFO, " Errors: %d", global_test_stats.total_error);
if (global_test_stats.total_fail == 0 && global_test_stats.total_error == 0) {
log_message(LOG_INFO, "ALL IMPLEMENTED TESTS PASSED!");
} else {
log_message(LOG_ERROR, "%d tests FAILED or had ERRORS!",
global_test_stats.total_fail + global_test_stats.total_error);
}
if (contract_get_violation_count() > 0) {
log_message(LOG_ERROR, " Contract violations (A4'/A1): %d *** AXIOM WITNESSES FAILED ***",
contract_get_violation_count());
} else {
log_message(LOG_INFO, " Contract checks (A4'/A1): all passed");
}
log_message(LOG_INFO, "==============================================");
}
/**
* @brief Run tests for a specific module
*
* @param vm Pointer to the Forth virtual machine instance
* @param module_name Name of the module to test
*/
void run_module_tests(VM *vm, const char *module_name) {
for (int i = 0; test_modules[i].module_name != NULL; i++) {
if (strcmp(test_modules[i].module_name, module_name) == 0) {
if (benchmark_mode) {
log_message(LOG_INFO, "Benchmarking module: %s", module_name);
if (test_modules[i].run_module_tests != NULL) {
/* Warmup */
test_modules[i].run_module_tests(vm);
/* Benchmark */
uint64_t start_time = get_time_ns();
for (int iter = 0; iter < benchmark_iterations; iter++) {
test_modules[i].run_module_tests(vm);
}
uint64_t end_time = get_time_ns();
uint64_t total_time = end_time - start_time;
double runs_per_second = (double) benchmark_iterations * 1000000000.0 / total_time;
log_message(LOG_INFO, " %.0f runs/sec | %.1f μs/run",
runs_per_second,
(double) total_time / benchmark_iterations / 1000.0);
} else {
log_message(LOG_WARN, "No tests implemented for module: %s", module_name);
}
} else {
log_message(LOG_INFO, "Running tests for module: %s", module_name);
if (test_modules[i].run_module_tests != NULL) {
test_modules[i].run_module_tests(vm);
} else {
log_message(LOG_WARN, "No tests implemented for module: %s", module_name);
}
}
return;
}
}
log_message(LOG_ERROR, "Unknown test module: %s", module_name);
}
/**
* @brief Run tests for a specific Forth word
*
* Searches all modules for tests related to the specified word and executes them.
*
* @param vm Pointer to the Forth virtual machine instance
* @param word_name Name of the Forth word to test
*/
void run_word_tests(VM *vm, const char *word_name) {
(void)vm;
log_message(LOG_INFO, "Searching for tests for word: %s", word_name);
int found = 0;
for (int i = 0; test_modules[i].module_name != NULL; i++) {
/* This would need to be implemented in each module */
/* For now, just run all tests - individual word testing can be added later */
}
if (!found) {
log_message(LOG_WARN, "No tests found for word: %s", word_name);
}
}
v3/src/vm.c
+981
View File
@@ -0,0 +1,981 @@
/*
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.
*/
/*
* vm.c (vm_core) - The VM is: state, invariants, execution spine
*
* Contains:
* - instruction dispatch loop
* - stack ops
* - dictionary lookup
* - word execution
* - VM flags / modes
* - anything that mutates VM state directly
*
* Rule: If it touches the stacks, it lives here.
*/
#include "vm_internal.h"
#include "../include/log.h"
#include "../include/profiler.h"
#include "../include/physics_metadata.h"
#include "../include/physics_execution_hooks.h"
#include "../include/physics_hotwords_cache.h"
#include <stdlib.h>
#include <string.h>
#include <stdint.h>
/* ====================== Base helpers ======================= */
/**
* @brief Read the current number base from the VM.
*
* Prefers the cell stored at @c vm->base_addr (the canonical FORTH
* @c BASE variable) if it is aligned and in the valid range [2, 36].
* Falls back to the host-mirror @c vm->base if the cell is out of
* range, and finally returns 10 if both are invalid or @p vm is NULL.
*
* The double-read (cell + mirror) keeps the VM consistent when C code
* modifies @c vm->base directly without going through @c vm_set_base().
*
* @param vm VM instance to query (may be NULL; returns 10 in that case).
* @return Current number base in range [2, 36].
*/
unsigned vm_get_base(const VM* vm)
{
if (!vm) return 10u;
/* Prefer VM cell if valid */
vaddr_t a = vm->base_addr;
if ((a % sizeof(cell_t)) == 0 && (size_t)a + sizeof(cell_t) <= VM_MEMORY_SIZE)
{
cell_t v = vm_load_cell((VM*)vm, a); /* cast-away const for accessor */
if (v >= 2 && v <= 36) return (unsigned)v;
}
/* Fallback to host mirror */
if (vm->base >= 2 && vm->base <= 36) return (unsigned)vm->base;
return 10u;
}
/**
* @brief Set the VM number base and update both the cell and the host mirror.
*
* Clamps @p b to [2, 36] (replacing out-of-range values with 10), then
* writes to the FORTH @c BASE variable cell at @c vm->base_addr and to
* the host-mirror field @c vm->base so both sources agree.
*
* @param vm VM instance to update.
* @param b Desired number base; clamped to [2, 36].
*/
void vm_set_base(VM* vm, unsigned b)
{
if (!vm) return;
if (b < 2 || b > 36) b = 10;
vm_store_cell(vm, vm->base_addr, (cell_t)b);
vm->base = (cell_t)b; /* host mirror */
}
/* vm_init and vm_cleanup moved to vm_bootstrap.c */
/* vm_tick* and heartbeat functions moved to vm_time.c */
/**
* @brief One-time write of the Zuse cert (seed + derived pubkey) -- blows
* the fuse.
*
* Deliberately not backed by a dictionary CONSTANT: ACL-PIN only blocks
* redefinition (vm_create_word shadowing), not a >BODY-then-store on the
* word's data field, so a pinned CONSTANT is not actually immutable against
* FORTH-level tampering. Keeping the value in a VM struct field with no
* corresponding FORTH store word closes that path entirely -- see
* FABRIC-2.md's Milestone 4 mint-then-pin writeup for the finding.
*
* @param vm VM instance.
* @param seed Ed25519 seed, 32 bytes (the private identity).
* @param pubkey Ed25519 public key derived from seed, 32 bytes.
* @return 0 on success; -1 if already installed (fuse already blown).
*/
int vm_zuse_cert_install(VM* vm, const uint8_t seed[32], const uint8_t pubkey[32])
{
if (!vm) return -1;
if (vm->zuse_cert_installed) return -1;
memcpy(vm->zuse_cert_seed, seed, 32);
memcpy(vm->zuse_cert_pubkey, pubkey, 32);
vm->zuse_cert_installed = 1;
return 0;
}
/* ====================== Parser / number ======================= */
/**
* @brief Parse the next whitespace-delimited token from the input buffer.
*
* Skips leading whitespace (space, tab, CR, LF), then extracts characters
* until the next whitespace or end of buffer, storing up to @p max_len − 1
* characters in @p word followed by a NUL terminator. Advances
* @c vm->input_pos past the consumed token.
*
* @param vm VM instance; @c vm->input_buffer / @c input_pos / @c input_length
* must be populated (typically by @c vm_interpret()).
* @param word Output buffer for the parsed token.
* @param max_len Size of @p word in bytes (including NUL terminator).
* @return Number of characters written (excluding NUL), or 0 if
* the buffer is exhausted or @p vm / @p word is NULL.
*/
int vm_parse_word(VM* vm, char* word, size_t max_len)
{
if (!vm || !word || max_len == 0) return 0;
/* Skip whitespace */
while (vm->input_pos < vm->input_length)
{
char c = vm->input_buffer[vm->input_pos];
if (c != ' ' && c != '\t' && c != '\n' && c != '\r') break;
vm->input_pos++;
}
if (vm->input_pos >= vm->input_length) return 0;
size_t len = 0;
while (vm->input_pos < vm->input_length && len < max_len - 1)
{
char c = vm->input_buffer[vm->input_pos];
if (c == ' ' || c == '\t' || c == '\n' || c == '\r') break;
word[len++] = c;
vm->input_pos++;
}
word[len] = '\0';
return (int)len;
}
/**
* @brief Attempt to parse a string as an integer in the current number base.
*
* Reads the current base from @c vm_get_base(), then converts each
* character of @p s (case-insensitive, digits 0–9 and letters A–Z/a–z)
* to a digit value. Returns 0 immediately on any character that is not
* a valid digit in the current base, or on an empty string after the
* optional sign.
*
* Handles an optional leading @c '+' or @c '-' sign. The result is a
* full-width @c cell_t (sign extended for negative values).
*
* @param vm VM instance (used for base only; may be NULL, in which case
* base defaults to 10).
* @param s NUL-terminated string to parse.
* @param out Pointer to receive the parsed value on success.
* @return 1 on successful parse, 0 on any parse failure.
*/
int vm_parse_number(VM* vm, const char* s, cell_t* out)
{
if (!s || !*s || !out) return 0;
unsigned base = vm_get_base(vm);
int neg = 0;
if (*s == '+' || *s == '-')
{
neg = (*s == '-');
s++;
if (!*s) return 0;
}
unsigned long long acc = 0;
int any = 0;
for (const char* p = s; *p; ++p)
{
unsigned d;
unsigned char c = (unsigned char)*p;
if (c >= '0' && c <= '9') d = (unsigned)(c - '0');
else if (c >= 'A' && c <= 'Z') d = 10u + (unsigned)(c - 'A');
else if (c >= 'a' && c <= 'z') d = 10u + (unsigned)(c - 'a');
else return 0;
if (d >= base) return 0;
acc = acc * base + d;
any = 1;
}
if (!any) return 0;
cell_t v = (cell_t)acc;
if (neg) v = (cell_t)(-v);
*out = v;
return 1;
}
/* ====================== Compile state ======================= */
/**
* @brief Begin a colon definition and switch the VM to compile mode.
*
* Creates a new dictionary entry for @p name via @c vm_create_word(),
* marks it @c WORD_SMUDGED so it is invisible to lookups during
* compilation, sets the VM mode to @c MODE_COMPILE, and writes the
* current @c HERE address into the entry's data field as the start of
* the threaded body.
*
* The SMUDGE flag is cleared by @c vm_exit_compile_mode() when the
* semicolon is encountered.
*
* @param vm VM instance.
* @param name Word name string (does not need to be NUL-terminated).
* @param len Length of @p name; clamped to @c WORD_NAME_MAX.
*/
void vm_enter_compile_mode(VM* vm, const char* name, size_t len)
{
if (!vm) return;
vm->mode = MODE_COMPILE;
vm->state_var = -1;
vm_store_cell(vm, vm->state_addr, vm->state_var);
if (len > WORD_NAME_MAX) len = WORD_NAME_MAX;
memcpy(vm->current_word_name, name, len);
vm->current_word_name[len] = '\0';
/* Create colon word header with code pointer = execute_colon_word */
DictEntry* de = vm_create_word(vm, name, len, execute_colon_word);
vm->compiling_word = de;
if (!de)
{
vm->error = 1;
return;
}
de->flags |= WORD_SMUDGED;
/* DF (first data cell) will hold the VM-relative address of threaded body */
vm_align(vm);
cell_t* df = vm_dictionary_get_data_field(de);
if (!df)
{
vm->error = 1;
return;
}
*df = (cell_t)(int64_t)((vaddr_t)vm->here);
log_message(LOG_DEBUG, ": started '%s' at HERE=%zu", vm->current_word_name, vm->here);
}
/**
* @brief Append a word reference (DictEntry*) to the current threaded body.
*
* Aligns @c HERE, then allots one @c cell_t slot and stores the
* @c DictEntry* as a cell. This is the fundamental compilation step used
* by the inner interpreter: each slot in the threaded body is a pointer
* to the @c DictEntry of the word to call.
*
* Sets @c vm->error if the VM is not in compile mode, @p entry is NULL,
* or allotment fails.
*
* @param vm VM instance in compile mode.
* @param entry Dictionary entry of the word to compile; must not be NULL.
*/
void vm_compile_word(VM* vm, DictEntry* entry)
{
if (!vm || vm->mode != MODE_COMPILE) return;
if (!entry)
{
vm->error = 1;
return;
}
vm_align(vm);
cell_t* slot = (cell_t*)vm_allot(vm, sizeof(cell_t));
if (!slot)
{
vm->error = 1;
return;
}
*slot = (cell_t)(uintptr_t)
entry; /* threaded code stores DictEntry* as cell */
}
/**
* @brief Compile a literal value into the current threaded body (or push it).
*
* In compile mode, appends the @c LIT word reference followed by the
* literal value so the inner interpreter will push @p value at runtime.
* In interpret mode, pushes @p value directly onto the data stack.
*
* Sets @c vm->error if @c LIT cannot be found in the dictionary.
*
* @param vm VM instance.
* @param value Cell value to compile or push.
*/
void vm_compile_literal(VM* vm, cell_t value)
{
if (!vm) return;
if (vm->mode != MODE_COMPILE)
{
vm_push(vm, value);
return;
}
DictEntry* LIT = vm_find_word(vm, "LIT", 3);
if (!LIT)
{
vm->error = 1;
log_message(LOG_ERROR, "LIT not found");
return;
}
vm_compile_word(vm, LIT);
vm_align(vm);
cell_t* val = (cell_t*)vm_allot(vm, sizeof(cell_t));
if (!val)
{
vm->error = 1;
return;
}
*val = value;
}
/**
* @brief Compile a call to a word identified by its C function pointer.
*
* Looks up the @c DictEntry whose @c func field matches @p func via
* @c vm_dictionary_find_by_func(), then delegates to @c vm_compile_word().
* Used by generating words (e.g., @c DOES>) that need to embed a specific
* runtime routine into a compiled definition without knowing its name.
*
* Sets @c vm->error if not in compile mode or if no matching entry is found.
*
* @param vm VM instance in compile mode.
* @param func C function pointer identifying the word to compile.
*/
void vm_compile_call(VM* vm, word_func_t func)
{
if (!vm || vm->mode != MODE_COMPILE)
{
vm->error = 1;
return;
}
DictEntry* entry = vm_dictionary_find_by_func(vm, func);
if (!entry)
{
vm->error = 1;
log_message(LOG_ERROR, "vm_compile_call: entry not found");
return;
}
vm_compile_word(vm, entry);
}
/**
* @brief Compile an @c EXIT reference into the current threaded body.
*
* Appends the @c EXIT word entry so that when the threaded body is
* executed, @c execute_colon_word() sets @c vm->exit_colon and unwinds
* the inner loop. Used by control-flow generating words (e.g., @c IF
* optimisation paths) that need an explicit early-return.
*
* Sets @c vm->error if not in compile mode or if @c EXIT is not found.
*
* @param vm VM instance in compile mode.
*/
void vm_compile_exit(VM* vm)
{
if (!vm || vm->mode != MODE_COMPILE) return;
DictEntry* EXIT = vm_find_word(vm, "EXIT", 4);
if (!EXIT)
{
vm->error = 1;
log_message(LOG_ERROR, "EXIT not found");
return;
}
vm_compile_word(vm, EXIT);
}
/**
* @brief Finalise a colon definition and return to interpret mode.
*
* Appends a final @c EXIT reference, clears the @c WORD_SMUDGED flag so
* the new word becomes visible in the dictionary, and sets @c WORD_COMPILED.
* Also computes the word's mass (header + body bytes) for the physics
* engine and calls @c physics_metadata_refresh_state().
*
* Resets @c vm->mode to @c MODE_INTERPRET, clears @c vm->state_var,
* and NULLs @c vm->compiling_word.
*
* Sets @c vm->error if @p vm has no active @c compiling_word or if
* @c EXIT cannot be found.
*
* @param vm VM instance currently in compile mode.
*/
void vm_exit_compile_mode(VM* vm)
{
if (!vm || !vm->compiling_word)
{
vm->error = 1;
return;
}
DictEntry* EXIT = vm_find_word(vm, "EXIT", 4);
if (!EXIT)
{
vm->error = 1;
log_message(LOG_ERROR, "EXIT not found");
return;
}
vm_compile_word(vm, EXIT);
vm->compiling_word->flags &= ~WORD_SMUDGED;
vm->compiling_word->flags |= WORD_COMPILED;
/* Cache coherence: the definition just became visible and now shadows
* any older word of the same name the hot-words cache may still hold. */
hotwords_cache_evict_name(vm->hotwords_cache,
vm->compiling_word->name,
vm->compiling_word->name_len);
/* Inherit creator's ACL from session context:
* zuse-compiled words bypass ACL-RECHECK on first execution (ACL_TTL_OPEN).
* Non-zuse words keep ttl=0, triggering ACL-RECHECK on first execution. */
if (vm->zuse_session) {
vm->compiling_word->acl_ttl = ACL_TTL_OPEN;
vm->compiling_word->acl_allow = 1;
}
cell_t* df = vm_dictionary_get_data_field(vm->compiling_word);
if (df)
{
uint64_t header_bytes = (uint64_t)(((uint8_t*)df + sizeof(cell_t)) - (uint8_t*)vm->compiling_word);
uint64_t body_start = (uint64_t)(vaddr_t)(uint64_t)(*df);
uint64_t here_bytes = (uint64_t)vm->here;
uint64_t body_bytes = (here_bytes >= body_start) ? (here_bytes - body_start) : 0;
uint64_t total = header_bytes + body_bytes;
uint32_t mass = (total > UINT32_MAX) ? UINT32_MAX : (uint32_t)total;
physics_metadata_set_mass(vm->compiling_word, mass);
}
physics_metadata_refresh_state(vm->compiling_word);
vm->mode = MODE_INTERPRET;
vm->state_var = 0;
vm_store_cell(vm, vm->state_addr, vm->state_var);
vm->compiling_word = NULL;
log_message(LOG_DEBUG, "; end definition");
}
/* ====================== Inner interpreter ======================= */
/*
Threaded code layout (compiled by vm_compile_word / vm_compile_literal):
DF cell (in DictEntry) holds a VM address (vaddr_t) of the first code cell.
Each code cell is a cell_t that encodes a DictEntry* (for a word to call),
or is a literal payload following a compiled LIT word.
Control-flow runtime words (e.g., (BRANCH), (0BRANCH), (DO), loops) are
responsible for *modifying the IP stored at the top of the return stack*.
The inner interpreter saves the "next ip" on the return stack before
calling the word; after the word returns, we pop the possibly-modified IP
and continue. This matches your runtime branch helpers' contract.
IMPORTANT: EXIT behavior —
Words implement EXIT by setting vm->exit_colon = 1 (one-shot).
We honor that flag here to unwind the *current* colon only,
without disturbing the caller’s R-stack frame.
*/
/**
* @brief Cold-path ACL enforcement called when a word's TTL counter hits zero.
*
* Looks up the FORTH word @c ACL-RECHECK in the dictionary. If found,
* calls it with @c emergency_console temporarily set to 1 so the recheck
* itself cannot be denied by the ACL system. The FORTH word is expected
* to update @c entry->acl_allow and @c entry->acl_ttl before returning.
*
* If @c ACL-RECHECK is not yet loaded (early boot before @c ACL.4th runs),
* the function **fails open**: sets @c acl_allow=1 and @c acl_ttl=ACL_TTL_OPEN
* so execution continues unimpeded. The same fail-open behaviour applies
* if @c ACL-RECHECK itself raises an error (error flag is cleared).
*
* This function is the cold path; the hot path in @c execute_colon_word()
* and @c vm_interpret_word() simply decrements @c acl_ttl.
*
* @param vm VM instance.
* @param entry Dictionary entry whose TTL has expired and needs rechecking.
*/
static void acl_recheck(VM *vm, DictEntry *entry)
{
DictEntry *recheck = vm_find_word(vm, "ACL-RECHECK", 11);
if (!recheck || !recheck->func) {
/* ACL.4th not yet loaded — fail open */
entry->acl_allow = 1;
entry->acl_ttl = ACL_TTL_OPEN;
return;
}
/* Push XT, call ACL-RECHECK with emergency bypass so it cannot deny itself */
uint8_t saved_ec = vm->emergency_console;
vm->emergency_console = 1;
vm_push(vm, (cell_t)(uintptr_t)entry);
DictEntry *saved_ce = vm->current_executing_entry;
vm->current_executing_entry = recheck;
recheck->func(vm);
vm->current_executing_entry = saved_ce;
vm->emergency_console = saved_ec;
/* If ACL-RECHECK itself errored, fail open and clear the error */
if (vm->error) {
vm->error = 0;
entry->acl_allow = 1;
entry->acl_ttl = ACL_TTL_OPEN;
log_message(LOG_WARN, "acl_recheck: ACL-RECHECK errored for '%.*s'; failing open",
(int)entry->name_len, entry->name);
}
}
/**
* @brief Inner interpreter for threaded colon definitions.
*
* Runs the body of a colon-defined word whose @c DictEntry points to a
* sequence of @c DictEntry* cells in VM memory (indirect threaded code).
* The interpreter pointer (IP) is maintained on the return stack so that
* runtime control-flow words (@c (BRANCH), @c (0BRANCH), @c (DO), etc.)
* can redirect execution by modifying the top-of-return-stack IP.
*
* **Execution loop per iteration:**
* 1. Read @c DictEntry* @c w from @c *ip.
* 2. Run physics pre-execute hooks (heat, decay, pipelining).
* 3. ACL hot-path check (decrement TTL; call @c acl_recheck() on zero).
* 4. Push @c ip+1 onto the return stack as the resume point.
* 5. Call @c w->func(vm).
* 6. Run physics post-execute hooks.
* 7. Check @c vm->exit_colon (set by @c EXIT): pop and discard the saved
* IP, then return to caller.
* 8. Check @c vm->abort_requested: unwind and return immediately.
* 9. Pop the (possibly modified) IP from the return stack and repeat.
*
* @c vm->ecw_nesting is incremented on entry and decremented on every
* return path to enable recursive colon calls.
*
* @param vm VM instance; @c vm->current_executing_entry must point to
* the @c DictEntry being executed.
*/
void execute_colon_word(VM* vm)
{
if (!vm || !vm->current_executing_entry) return;
DictEntry* entry = vm->current_executing_entry;
cell_t* df = vm_dictionary_get_data_field(entry);
if (!df) { vm->error = 1; return; }
vaddr_t body_addr = (vaddr_t)(uint64_t)(*df);
cell_t* ip = (cell_t*)vm_ptr(vm, body_addr);
if (!ip) { vm->error = 1; return; }
DictEntry* prev = NULL;
vm->ecw_nesting++;
for (;;)
{
DictEntry* w = (DictEntry*)(uintptr_t)(*ip);
/* Physics: pre-execution hooks (decay, heat, pipelining) */
physics_pre_execute(vm, w, prev);
profiler_word_count(w);
/* ACL two-level check (hot path: decrement TTL; cold path: recheck) */
if (w && !vm->emergency_console) {
if (w->acl_ttl == 0)
acl_recheck(vm, w);
else
w->acl_ttl--;
if (!w->acl_allow) {
log_message(LOG_WARN, "ACL: denied '%.*s'", (int)w->name_len, w->name);
vm->dsp = -1;
vm->rsp = -1;
vm->error = 1;
return;
}
}
/* Advance IP and save resume point */
ip++;
vm_rpush(vm, (cell_t)(uintptr_t)ip);
if (vm->error) { vm->ecw_nesting--; return; }
/* Execute the word */
vm->current_executing_entry = w;
if (w && w->func)
{
profiler_word_enter(w);
w->func(vm);
physics_post_execute(vm, w);
}
else
{
const char *pname = (entry && entry->name_len > 0) ? entry->name : "?";
if (!w)
log_message(LOG_ERROR, "execute_colon_word: NULL DictEntry* in '%s' (ip-1=%p)",
pname, (void *)(ip - 1));
else
log_message(LOG_ERROR, "execute_colon_word: null func for '%s' in '%s' (ip-1=%p)",
w->name, pname, (void *)(ip - 1));
vm->error = 1;
}
vm->current_executing_entry = entry;
prev = w;
if (vm->error) { vm->ecw_nesting--; return; }
/* ABORT clears stacks and unwinds to QUIT: leave the flag set so
* every enclosing colon-word frame (this function is recursive --
* every colon word's func is execute_colon_word) also sees it and
* also unwinds, instead of consuming it at the first frame that
* notices. The outermost caller (vm_interpret et al.) is
* responsible for finally clearing it. */
if (vm->abort_requested) { vm->ecw_nesting--; return; }
/* EXIT discards saved IP and returns */
if (vm->exit_colon)
{
vm->exit_colon = 0;
(void)vm_rpop(vm);
vm->ecw_nesting--;
return;
}
/* Resume at (possibly modified) IP from return stack */
ip = (cell_t*)(uintptr_t)vm_rpop(vm);
if (vm->error) { vm->ecw_nesting--; return; }
}
}
/* ====================== Outer interpreter ======================= */
/**
* @brief Interpret or compile a single word token.
*
* This is the outer interpreter's per-token dispatch:
*
* 1. **Dictionary lookup**: vocabulary-aware search, falling back to the
* canonical flat dictionary. Physics heat is recorded via
* @c physics_on_lookup().
* 2. **Compile mode, non-immediate**: append the entry to the current
* threaded body via @c vm_compile_word().
* 3. **Interpret mode, or immediate in compile mode**: ACL check (hot-path
* TTL decrement / cold-path @c acl_recheck()), then call @c entry->func().
* 4. **Number literal**: if no dictionary match, attempt @c vm_parse_number().
* In compile mode, compile as a literal; in interpret mode, push directly.
* 5. **Error**: unknown token — sets @c vm->error.
*
* @param vm VM instance.
* @param word_str Token string (need not be NUL-terminated).
* @param len Length of @p word_str in bytes.
*/
void vm_interpret_word(VM* vm, const char* word_str, size_t len)
{
if (!vm || !word_str) return;
log_message(LOG_DEBUG, "INTERPRET: '%.*s' (mode=%s)",
(int)len, word_str,
vm->mode == MODE_COMPILE ? "COMPILE" : "INTERPRET");
/* Vocabulary-aware lookup with fallback to canonical dictionary */
extern DictEntry* vm_vocabulary_find_word(VM* vm, const char* name, size_t nlen);
DictEntry* entry = vm_vocabulary_find_word(vm, word_str, len);
DictEntry* canon = vm_find_word(vm, word_str, len);
if (!entry) entry = canon;
if (entry)
{
/* Physics: track lookup (heat, decay) */
physics_on_lookup(vm, entry, canon);
int is_immediate = ((entry->flags & WORD_IMMEDIATE) ||
(canon && (canon->flags & WORD_IMMEDIATE)));
if (vm->mode == MODE_COMPILE && !is_immediate)
{
log_message(LOG_DEBUG, "COMPILE: '%.*s'", (int)len, word_str);
vm_compile_word(vm, entry);
return;
}
log_message(LOG_DEBUG, "EXECUTE: '%.*s'", (int)len, word_str);
vm->current_executing_entry = entry;
profiler_word_count(entry);
/* ACL check on outer-interpreter path */
if (!vm->emergency_console) {
if (entry->acl_ttl == 0)
acl_recheck(vm, entry);
else
entry->acl_ttl--;
if (!entry->acl_allow) {
log_message(LOG_WARN, "ACL: denied '%.*s'", (int)len, word_str);
vm->dsp = -1;
vm->rsp = -1;
vm->error = 1;
vm->current_executing_entry = NULL;
return;
}
}
if (entry->func)
{
profiler_word_enter(entry);
entry->func(vm);
physics_post_execute(vm, entry);
}
else
{
log_message(LOG_ERROR, "NULL func for '%.*s'", (int)len, word_str);
vm->error = 1;
}
vm->current_executing_entry = NULL;
return;
}
/* Try parsing as number */
cell_t value;
if (vm_parse_number(vm, word_str, &value))
{
log_message(LOG_DEBUG, "NUMBER: '%.*s' = %ld", (int)len, word_str, (long)value);
if (vm->mode == MODE_COMPILE)
vm_compile_literal(vm, value);
else
vm_push(vm, value);
return;
}
log_message(LOG_ERROR, "UNKNOWN WORD: '%.*s'", (int)len, word_str);
vm->error = 1;
}
/**
* @brief Interpret a NUL-terminated string of FORTH source code.
*
* Copies @p input into @c vm->input_buffer (capped at
* @c INPUT_BUFFER_SIZE − 1 bytes, NUL-terminated), then drives the
* word-parse / token-dispatch loop until the buffer is exhausted or
* @c vm->error is set. Each token is dispatched to @c vm_interpret_word().
*
* This is the top-level entry point used by the REPL, @c INCLUDE, and
* inline @c -c execution. It does not reset @c vm->error before running —
* the caller is responsible for clearing error state if desired.
*
* @param vm VM instance.
* @param input NUL-terminated FORTH source string to interpret.
*/
void vm_interpret(VM* vm, const char* input)
{
if (!vm || !input) return;
/* Load into input buffer (cap + NUL) */
size_t n = 0, cap = INPUT_BUFFER_SIZE ? INPUT_BUFFER_SIZE - 1 : 0;
while (n < cap)
{
char c = input[n];
vm->input_buffer[n] = c;
if (c == '\0') break;
++n;
}
if (n == cap) vm->input_buffer[n] = '\0';
vm->input_length = n;
vm->input_pos = 0;
char word[64];
size_t wlen;
/* !abort_requested: ABORT unwinds all the way to QUIT -- stop parsing
* further words in this input the moment it's seen. Flag is left set
* on return; caller (REPL, exec_block_with_retry, etc.) consumes it. */
while (!vm->error && !vm->abort_requested &&
(wlen = (size_t)vm_parse_word(vm, word, sizeof(word))) > 0)
{
vm_interpret_word(vm, word, wlen);
}
}
/* ====================== VM memory helpers ======================= */
/**
* @brief Validate that a VM address range lies within @c vm->memory.
*
* Checks that [addr, addr+len) is fully contained within the
* @c VM_MEMORY_SIZE-byte flat address space. The check is done with
* unsigned arithmetic to avoid UB on overflow: if @p len alone exceeds
* @c VM_MEMORY_SIZE the range is immediately rejected.
*
* @param vm VM instance; returns 0 if NULL or memory not allocated.
* @param addr Start of the range (inclusive).
* @param len Number of bytes in the range.
* @return 1 if the full range [addr, addr+len) is in bounds; 0 otherwise.
*/
int vm_addr_ok(struct VM* vm, vaddr_t addr, size_t len)
{
if (!vm || !vm->memory) return 0;
if (len > VM_MEMORY_SIZE) return 0;
return addr <= (vaddr_t)(VM_MEMORY_SIZE - len);
}
/**
* @brief Return a host C pointer into VM memory at @p addr.
*
* Validates the address with @c vm_addr_ok() (minimum 1-byte range) and
* returns @c NULL if the address is out of bounds or @p vm is uninitialised.
* The returned pointer is valid for at least one byte; callers that need
* multi-byte access should perform their own range check first.
*
* @param vm VM instance.
* @param addr VM byte offset to dereference.
* @return Host pointer into @c vm->memory, or NULL on bounds failure.
*/
uint8_t* vm_ptr(struct VM* vm, vaddr_t addr)
{
if (!vm || !vm->memory) return NULL;
if (!vm_addr_ok(vm, addr, 1)) return NULL;
return vm->memory + (size_t)addr;
}
/**
* @brief Load an unsigned byte from VM memory.
*
* Resolves @p addr via @c vm_ptr(). Sets @c vm->error and returns 0 if
* the address is out of bounds.
*
* @param vm VM instance.
* @param addr VM byte offset to read.
* @return Byte value at @p addr, or 0 on error.
*/
uint8_t vm_load_u8(struct VM* vm, vaddr_t addr)
{
uint8_t* p = vm_ptr(vm, addr);
if (!p)
{
vm->error = 1;
return 0;
}
return *p;
}
/**
* @brief Store an unsigned byte to VM memory.
*
* Resolves @p addr via @c vm_ptr(). Sets @c vm->error if the address
* is out of bounds; otherwise writes @p v.
*
* @param vm VM instance.
* @param addr VM byte offset to write.
* @param v Byte value to store.
*/
void vm_store_u8(struct VM* vm, vaddr_t addr, uint8_t v)
{
uint8_t* p = vm_ptr(vm, addr);
if (!p)
{
vm->error = 1;
return;
}
*p = v;
}
/**
* @brief Load an aligned cell from VM memory.
*
* Validates that @p addr is within bounds for a full @c cell_t read and
* that it is naturally aligned (addr % sizeof(cell_t) == 0). Uses
* @c memcpy() rather than a direct pointer dereference to avoid strict
* aliasing and alignment UB. Sets @c vm->error and returns 0 on failure.
*
* @param vm VM instance.
* @param addr Aligned VM byte offset to read.
* @return Cell value at @p addr, or 0 on alignment or bounds error.
*/
cell_t vm_load_cell(struct VM* vm, vaddr_t addr)
{
if (!vm_addr_ok(vm, addr, sizeof(cell_t)) || (addr % sizeof(cell_t)) != 0)
{
vm->error = 1;
return 0;
}
cell_t out = 0;
memcpy(&out, vm->memory + (size_t)addr, sizeof(cell_t));
return out;
}
/**
* @brief Store an aligned cell to VM memory.
*
* Validates alignment and bounds, then copies @p v into VM memory via
* @c memcpy(). Sets @c vm->error on alignment or bounds failure.
*
* @param vm VM instance.
* @param addr Aligned VM byte offset to write.
* @param v Cell value to store.
*/
void vm_store_cell(struct VM* vm, vaddr_t addr, cell_t v)
{
if (!vm_addr_ok(vm, addr, sizeof(cell_t)) || (addr % sizeof(cell_t)) != 0)
{
vm->error = 1;
return;
}
memcpy(vm->memory + (size_t)addr, &v, sizeof(cell_t));
}
/* vm_bootstrap_scr moved to vm_bootstrap.c */
/**
* @brief Mark the most recently created word as IMMEDIATE (FORTH-79).
*
* Sets @c WORD_IMMEDIATE on @c vm->latest so the word executes during
* compilation rather than being compiled into the current definition.
* Also calls @c physics_metadata_refresh_state() to update the physics
* engine's record of the entry's flags.
*
* Sets @c vm->error if @p vm has no @c latest entry (i.e., the dictionary
* is empty or no word has been created yet).
*
* @param vm VM instance.
*/
void vm_make_immediate(VM* vm)
{
if (!vm) return;
if (!vm->latest)
{
log_message(LOG_ERROR, "vm_make_immediate: no latest word to mark IMMEDIATE");
vm->error = 1;
return;
}
vm->latest->flags |= WORD_IMMEDIATE;
physics_metadata_refresh_state(vm->latest);
log_message(LOG_DEBUG, "IMMEDIATE: '%.*s'",
(int)vm->latest->name_len, vm->latest->name);
}
v3/src/vm_api.c
+243
View File
@@ -0,0 +1,243 @@
/*
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/vm_api.h"
#include "../include/vm.h" // internal details, not re-exposed to word modules
#include <string.h>
/** @name Stack Operations
* @{
*/
/** @brief Push value onto data stack
* @param vm VM instance
* @param v Value to push
*/
void vm_api_push(VM *vm, intptr_t v) { vm_push(vm, v); }
/** @brief Pop value from data stack
* @param vm VM instance
* @return Popped value
*/
intptr_t vm_api_pop(VM *vm) { return vm_pop(vm); }
/** @brief Push value onto return stack
* @param vm VM instance
* @param v Value to push
*/
void vm_api_rpush(VM *vm, intptr_t v) { vm_rpush(vm, v); }
/** @brief Pop value from return stack
* @param vm VM instance
* @return Popped value
*/
intptr_t vm_api_rpop(VM *vm) { return vm_rpop(vm); }
/** @} */
/** @name Dictionary Operations
* @{
*/
/** @brief Create new word in dictionary
* @param vm VM instance
* @param n Word name
* @param len Name length
* @param fn Word implementation function
* @return Pointer to created dictionary entry
*/
void *vm_api_create_word(VM *vm, const char *n, size_t len, word_func_t fn) {
return (void *) vm_create_word(vm, n, len, (void(*)(struct VM *)) fn);
}
/** @brief Find word in dictionary
* @param vm VM instance
* @param n Word name to find
* @param len Name length
* @return Pointer to found dictionary entry or NULL
*/
void *vm_api_find_word(VM *vm, const char *n, size_t len) {
return (void *) vm_find_word(vm, n, len);
}
/** @brief Hide last defined word
* @param vm VM instance
*/
void vm_api_hide_word(VM *vm) { vm_hide_word(vm); }
/** @brief Toggle smudge bit of last word
* @param vm VM instance
*/
void vm_api_smudge_word(VM *vm) { vm_smudge_word(vm); }
/** @} */
/** @brief Ensure input buffers are allocated
* @param vm VM instance
* @return 0 on success, 1 on error
* @details Allocates TIB buffer and input variables if not already allocated
*/
int vm_input_ensure(VM *vm) {
if (!vm) return 1;
if (!vm->tib_buf) {
vm->tib_buf = (unsigned char *) vm_allot(vm, INPUT_BUFFER_SIZE);
if (!vm->tib_buf) {
vm->error = 1;
return 1;
}
vm->tib_cap = INPUT_BUFFER_SIZE;
memset(vm->tib_buf, 0, vm->tib_cap);
}
if (!vm->in_var) {
/* INPUT_BUFFER_SIZE (1025) is not a cell multiple; align here->here before
* allocating cell-sized variables so their addresses pass the @ alignment check */
vm_align(vm);
vm->in_var = (cell_t *) vm_allot(vm, sizeof(cell_t));
if (!vm->in_var) {
vm->error = 1;
return 1;
}
*vm->in_var = 0;
}
if (!vm->span_var) {
vm->span_var = (cell_t *) vm_allot(vm, sizeof(cell_t));
if (!vm->span_var) {
vm->error = 1;
return 1;
}
*vm->span_var = 0;
}
return 0;
}
/** @brief Get pointer to terminal input buffer (TIB)
* @param vm VM instance
* @return Pointer to TIB or NULL on error
* @details Returns pointer to VM's terminal input buffer after ensuring it exists
*/
unsigned char *vm_input_tib(VM *vm) {
if (vm_input_ensure(vm)) return NULL;
return vm->tib_buf; /* VM address */
}
/** @brief Get pointer to input offset variable
* @param vm VM instance
* @return Pointer to input offset or NULL on error
* @details Returns pointer to VM's input offset variable after ensuring it exists
*/
cell_t *vm_input_in(VM *vm) {
if (vm_input_ensure(vm)) return NULL;
return vm->in_var; /* VM address */
}
/** @brief Get pointer to input span variable
* @param vm VM instance
* @return Pointer to span variable or NULL on error
* @details Returns pointer to VM's input span variable after ensuring it exists
*/
cell_t *vm_input_span(VM *vm) {
if (vm_input_ensure(vm)) return NULL;
return vm->span_var; /* VM address */
}
/** @brief Load input line into TIB
* @param vm VM instance
* @param src Source string to load
* @param n Number of characters to load
* @details Loads up to n characters from src into TIB, zero-pads remainder
* Resets input offset and updates span. Handles NULL src gracefully.
*/
void vm_input_load_line(VM *vm, const char *src, size_t n) {
if (vm_input_ensure(vm)) return;
if (!src) {
*vm->span_var = 0;
*vm->in_var = 0;
return;
}
size_t nclamp = n;
if (nclamp > vm->tib_cap) nclamp = vm->tib_cap;
memcpy(vm->tib_buf, src, nclamp);
if (nclamp < vm->tib_cap) memset(vm->tib_buf + nclamp, 0, vm->tib_cap - nclamp);
*vm->span_var = (cell_t) nclamp;
*vm->in_var = 0;
}
/** @brief Get current input source buffer info
* @param vm VM instance
* @param out_addr Output parameter for buffer address
* @param out_len Output parameter for buffer length
* @details Returns current input buffer address and length through parameters
* Both parameters are optional (can be NULL)
*/
void vm_input_source(VM *vm, cell_t *out_addr, cell_t *out_len) {
if (vm_input_ensure(vm)) {
if (out_addr) *out_addr = 0;
if (out_len) *out_len = 0;
return;
}
if (out_addr) *out_addr = (cell_t)(uintptr_t)
vm->tib_buf;
if (out_len) *out_len = (*vm->span_var < 0) ? 0 : *vm->span_var;
}
/** @name Memory Operations
* @{
*/
/** @brief Convert native pointer to Forth memory address
* @param vm VM instance
* @param p Native pointer to convert
* @return Forth memory address (offset from VM memory base)
* @details Converts a native C pointer to a Forth memory address by calculating
* offset from VM memory base. Returns 0 for invalid pointers.
*/
cell_t vm_addr_from_ptr(VM *vm, void *p) {
if (!vm || !p) return 0;
#if defined(VM_STRICT_PTR) && VM_STRICT_PTR
/* Forth addresses are real pointers */
return (cell_t)(uintptr_t)p;
#else
/* Forth addresses are offsets into vm->memory */
if (!vm->memory) return 0;
unsigned long base = (unsigned long) vm->memory;
unsigned long addr = (unsigned long) p;
if (addr < base) return 0;
return (cell_t)(addr - base);
#endif
}
/** @} */
v3/src/vm_bootstrap.c
+430
View File
@@ -0,0 +1,430 @@
/*
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.
*/
/*
* vm_bootstrap.c - How a VM comes into existence
*
* Contains:
* - dictionary seeding
* - primitive registration
* - initial vocabularies
* - host vs kernel bootstrap branching
* - early init code paths
*
* Rule: If it runs before the VM executes a single word, it belongs here.
*/
#include "vm_internal.h"
#include "../include/log.h"
#include "../include/word_registry.h"
#include "../include/vm_debug.h"
#include "../include/physics_hotwords_cache.h"
#include "../include/rolling_window_of_truth.h"
#include "../include/dictionary_heat_optimization.h"
#include "../include/ssm_jacquard.h"
#include "../include/platform_alloc.h"
#include "word_source/include/vocabulary_words.h"
#ifdef __STARKERNEL__
#include "starkernel/capsule_birth.h"
#include "starkernel/capsule_run.h"
#endif
#include <string.h>
/* ====================== Bootstrap helpers ======================= */
/**
* @brief Ensure the SCR (Screen) system variable cell is allocated and zeroed.
*
* If @c vm->scr_addr does not point to a valid, aligned cell inside the VM
* memory array, aligns the allocation pointer and allots a new cell.
* Always writes 0 to the SCR cell on exit. Called at the end of @c vm_init()
* to guarantee a clean SCR state regardless of how the initial allot
* sequence progressed.
*
* @param vm Active VM; sets @c vm->error = 1 and logs if allot fails
*/
static void vm_bootstrap_scr(VM* vm)
{
if (!vm) return;
/* Ensure SCR cell exists and is zero */
if (!vm_addr_ok(vm, vm->scr_addr, sizeof(cell_t)) ||
(vm->scr_addr % sizeof(cell_t)) != 0)
{
vm_align(vm);
void* p = vm_allot(vm, sizeof(cell_t));
if (!p)
{
vm->error = 1;
log_message(LOG_ERROR, "bootstrap SCR allot failed");
return;
}
vm->scr_addr = (vaddr_t)((uint8_t*)p - vm->memory);
}
vm_store_cell(vm, vm->scr_addr, 0);
}
/**
* @brief Bootstrap a root vocabulary for the VM
*
* Creates a vocabulary by name, finds its dictionary entry, executes
* it to make it current, then calls DEFINITIONS.
*
* @param vm Pointer to VM structure
* @param name Vocabulary name to bootstrap
*/
void vm_bootstrap_root_vocabulary(VM *vm, const char *name)
{
if (!vm || !name) {
return;
}
vocabulary_create_vocabulary_direct(vm, name);
size_t len = strlen(name);
DictEntry *entry = vm_find_word(vm, name, len);
if (!entry || !entry->func) {
vm->error = 1;
log_message(LOG_ERROR, "bootstrap: missing vocabulary '%s'", name);
return;
}
entry->func(vm);
vocabulary_word_definitions(vm);
}
/* ====================== VM init / teardown ======================= */
/**
* @brief Initialize a new virtual machine instance
*
* Allocates memory and initializes all VM structures including:
* - Memory array
* - Data and return stacks
* - System variables (SCR, STATE, BASE)
* - Dictionary
* - Forth-79 wordset
*
* @param vm Pointer to VM structure to initialize
*/
void vm_init(VM* vm)
{
if (!vm) return;
memset(vm, 0, sizeof(*vm));
vm->next_word_id = 0;
vm->recycled_word_id_count = 0;
if (sf_mutex_init(&vm->dict_lock) != 0)
{
log_message(LOG_ERROR, "vm_init: dict_lock init failed");
vm->error = 1;
return;
}
if (sf_mutex_init(&vm->tuning_lock) != 0)
{
log_message(LOG_ERROR, "vm_init: tuning_lock init failed");
sf_mutex_destroy(&vm->dict_lock);
vm->error = 1;
return;
}
vm->memory = (uint8_t*)sf_malloc(VM_MEMORY_SIZE);
if (!vm->memory)
{
log_message(LOG_ERROR, "vm_init: out of memory");
vm->error = 1;
return;
}
vm->dsp = -1;
vm->rsp = -1;
vm->here = 0;
vm->exit_colon = 0;
/* Control-flow bookkeeping sentinels (-1/-999 mean "empty"; memset above
* already zeroed the arrays themselves) */
vm->cf.cf_sp = -1;
vm->cf.cf_last_mode = -999;
vm->cf.leave_sp = -1;
vm->cf.leave_mark_sp = -1;
vm->cf.endof_sp = -1;
vm->cf.endof_mark_sp = -1;
vm->abort_requested = 0;
vm_align(vm);
/* SCR */
{
void* p = vm_allot(vm, sizeof(cell_t));
if (!p)
{
vm->error = 1;
log_message(LOG_ERROR, "vm_init: SCR allot failed");
return;
}
vm->scr_addr = (vaddr_t)((uint8_t*)p - vm->memory);
vm_store_cell(vm, vm->scr_addr, 0);
}
/* STATE (0=interpret, -1=compile) */
{
void* p = vm_allot(vm, sizeof(cell_t));
if (!p)
{
vm->error = 1;
log_message(LOG_ERROR, "vm_init: STATE allot failed");
return;
}
vm->state_addr = (vaddr_t)((uint8_t*)p - vm->memory);
vm_store_cell(vm, vm->state_addr, 0);
vm->state_var = 0;
}
/* BASE (default 10) */
{
void* p = vm_allot(vm, sizeof(cell_t));
if (!p)
{
vm->error = 1;
log_message(LOG_ERROR, "vm_init: BASE allot failed");
return;
}
vm->base_addr = (vaddr_t)((uint8_t*)p - vm->memory);
vm_set_base(vm, 10);
}
/* Pictured-number hold buffer (64 bytes, per-VM so child VMs are independent) */
{
void* p = vm_allot(vm, 64);
if (!p)
{
vm->error = 1;
log_message(LOG_ERROR, "vm_init: hold buffer allot failed");
return;
}
vm->hold_addr = (vaddr_t)((uint8_t*)p - vm->memory);
vm->hold_pos = 0;
memset(p, 0, 64);
}
vm_bootstrap_scr(vm);
vm->mode = MODE_INTERPRET;
vm->compiling_word = NULL;
vm->latest = NULL;
vm->error = 0;
vm->halted = 0;
vm->input_length = 0;
vm->input_pos = 0;
vm->current_executing_entry = NULL;
vm_debug_set_current_vm(vm);
vm_debug_install_signal_handlers();
/* Register Forth-79 wordset */
register_forth79_words(vm);
/* Set FORGET fence to post-boot */
vm->dict_fence_latest = vm->latest;
vm->dict_fence_here = vm->here;
/* Initialize hot-words cache (physics frequency-driven acceleration) */
vm->hotwords_cache = (HotwordsCache*)sf_malloc(sizeof(HotwordsCache));
if (!vm->hotwords_cache)
{
log_message(LOG_ERROR, "vm_init: hotwords cache alloc failed");
vm->error = 1;
return;
}
hotwords_cache_init(vm->hotwords_cache);
/* Initialize rolling window of truth (deterministic execution history) */
if (rolling_window_init(&vm->rolling_window) != 0)
{
log_message(LOG_ERROR, "vm_init: rolling window alloc failed");
vm->error = 1;
return;
}
/* Initialize VM heartbeat (centralized time-driven tuning) */
vm->heartbeat.tick_count = 0;
vm->heartbeat.last_inference_tick = 0;
vm->heartbeat.check_counter = 0;
vm->heartbeat.heartbeat_enabled = 1; /* Enabled by default */
vm->heartbeat.tick_target_ns = HEARTBEAT_TICK_NS;
vm->heartbeat.snapshot_index = 0;
vm->heartbeat.worker = NULL;
vm->heartbeat_decay_cursor_id = WORD_ID_INVALID;
/* Initialize pipelining global metrics (aggregated prefetch tracking) */
vm->pipeline_metrics.prefetch_attempts = 0;
vm->pipeline_metrics.prefetch_hits = 0;
vm->pipeline_metrics.window_tuning_checks = 0;
vm->pipeline_metrics.last_checked_window_size = vm->rolling_window.effective_window_size;
vm->pipeline_metrics.last_checked_accuracy = 0.0;
vm->pipeline_metrics.suggested_next_size = vm->rolling_window.effective_window_size;
vm_heartbeat_publish_snapshot(vm);
/* Start heartbeat thread (if enabled) */
vm_heartbeat_start_thread(vm);
/* Initialize adaptive heat decay tuning (Loop #3) */
/* Start with 2:1 ratio in Q48.16 format: 2.0 << 16 = 131072 */
vm->decay_slope_q48 = (1ULL << 16) / 3; /* 1/3 starting slope (Q48.16) */
vm->last_decay_check_ns = 0;
vm->total_heat_at_last_check = 0;
vm->stale_word_count_at_check = 0;
vm->decay_slope_direction = 0; /* Start neutral */
/* Phase 2: Initialize heat-aware dictionary optimization */
vm->lookup_strategy = 0; /* Start with naive lookup, will adapt based on patterns */
vm->last_bucket_reorg_ns = 0; /* Force first reorg quickly */
dict_update_heat_percentiles(vm); /* Calculate initial percentiles */
/* SSM L8: Jacquard Mode Selector initialization */
vm->ssm_l8_state = sf_malloc(sizeof(ssm_l8_state_t));
if (!vm->ssm_l8_state)
{
log_message(LOG_ERROR, "vm_init: SSM L8 state alloc failed");
vm->error = 1;
return;
}
ssm_l8_init((ssm_l8_state_t*)vm->ssm_l8_state, SSM_MODE_C0);
ssm_l8_init_table((ssm_l8_state_t*)vm->ssm_l8_state);
vm->ssm_config = sf_malloc(sizeof(ssm_config_t));
if (!vm->ssm_config)
{
log_message(LOG_ERROR, "vm_init: SSM config alloc failed");
vm->error = 1;
return;
}
/* Initialize with C0 (minimal) mode: all 7 loops off. The adaptive
* table's first trial-end (or an explicit ssm_apply_mode_from_table()
* call) overwrites this with the real DoE-seeded starting config. */
((ssm_config_t*)vm->ssm_config)->L1_heat_tracking = 0;
((ssm_config_t*)vm->ssm_config)->L2_rolling_window = 0;
((ssm_config_t*)vm->ssm_config)->L3_linear_decay = 0;
((ssm_config_t*)vm->ssm_config)->L4_pipelining = 0;
((ssm_config_t*)vm->ssm_config)->L5_window_inference = 0;
((ssm_config_t*)vm->ssm_config)->L6_decay_inference = 0;
((ssm_config_t*)vm->ssm_config)->L7_adaptive_heartrate = 0;
#ifdef __STARKERNEL__
/* Capsule subsystem: register VM hooks, init registry and run log.
* capsule_birth_mama() is called separately after vm_init() returns,
* once the caller has access to the compiled-in capsule directory. */
capsule_vm_hooks_register();
capsule_vm_registry_init();
capsule_run_log_init();
#endif
}
/**
* @brief Clean up and free VM resources
*
* Frees allocated memory and resets VM state.
*
* @param vm Pointer to VM structure to clean up
*/
void vm_cleanup(VM* vm)
{
if (!vm) return;
/* Stop heartbeat thread (if running) */
vm_heartbeat_stop_thread(vm);
/* Clean up hot-words cache */
if (vm->hotwords_cache)
{
hotwords_cache_cleanup(vm->hotwords_cache);
sf_free(vm->hotwords_cache);
vm->hotwords_cache = NULL;
}
/* Clean up rolling window of truth */
rolling_window_cleanup(&vm->rolling_window);
/* Clean up SSM L8 state */
if (vm->ssm_l8_state)
{
ssm_l8_free_table((ssm_l8_state_t*)vm->ssm_l8_state);
sf_free(vm->ssm_l8_state);
vm->ssm_l8_state = NULL;
}
if (vm->ssm_config)
{
sf_free(vm->ssm_config);
vm->ssm_config = NULL;
}
/* Same fix as the kernel's own vm_cleanup() (src/starkernel/vm/vm_core.c)
* -- every DictEntry is its own sf_malloc() (vm_create_word(),
* dictionary_management.c), separate from vm->memory entirely, and
* nothing anywhere ever freed them. Confirmed live via a kernel-side
* repeated birth/kill cycle exhausting the heap; this hosted copy of
* vm_cleanup() has the identical gap, just never noticed here because
* the hosted binary normally only calls this once at process exit. */
{
DictEntry *dict_entry = vm->latest;
while (dict_entry) {
DictEntry *next_entry = dict_entry->link;
if (dict_entry->transition_metrics) {
sf_free(dict_entry->transition_metrics);
}
sf_free(dict_entry);
dict_entry = next_entry;
}
vm->latest = NULL;
}
if (vm->memory)
{
sf_free(vm->memory);
vm->memory = NULL;
}
vm->here = 0;
sf_mutex_destroy(&vm->tuning_lock);
sf_mutex_destroy(&vm->dict_lock);
}
v3/src/vm_debug.c
+205
View File
@@ -0,0 +1,205 @@
/*
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/vm.h"
#include "../include/vm_debug.h"
/* No POSIX signals in the kernel — provide stubs and skip the rest. */
#if defined(STARFORTH_MINIMAL)
void vm_debug_set_current_vm(VM *vm) { (void)vm; }
void vm_debug_dump_state(const VM *vm, const char *reason) { (void)vm; (void)reason; }
void vm_debug_install_signal_handlers(void) {}
#else
#include <signal.h>
#include <stdio.h>
#include <string.h>
static VM *g_vm = NULL;
/* @brief Sets the current VM instance for debug operations
* @param vm Pointer to the VM instance to be monitored
*/
void vm_debug_set_current_vm(VM *vm) { g_vm = vm; }
/* Safe BASE read (never touches vm->error). Adjust if you have a helper. */
/** @brief Safely retrieves the current number base from VM
* @param vm Pointer to the VM instance
* @return Current number base (2-36) or 10 if invalid
*/
static unsigned dbg_get_base(const VM *vm) {
if (!vm) return 10u;
size_t idx = (size_t) vm->base_addr;
if (idx < (size_t) VM_MEMORY_SIZE) {
cell_t v = vm->memory[idx];
if (v >= 2 && v <= 36) return (unsigned) v;
}
if (vm->base >= 2 && vm->base <= 36) return (unsigned) vm->base;
return 10u;
}
/** @brief Converts VM mode to string representation
* @param m The VM mode value
* @return String representing the mode
*/
static const char *mode_str(int m) {
switch (m) {
case MODE_INTERPRET: return "INTERPRET";
case MODE_COMPILE: return "COMPILE";
default: return "UNKNOWN";
}
}
/** @brief Dumps preview of a block's contents
* @param vm Pointer to the VM instance
* @param scr Block number to preview
*/
static void dump_block_preview(const VM *vm, cell_t scr) {
if (!vm) return;
if (scr < 1 || scr >= (cell_t) MAX_BLOCKS) return;
vaddr_t addr = (vaddr_t)((unsigned long long) scr * (unsigned long long) BLOCK_SIZE);
if (!vm_addr_ok((VM *) vm, addr, BLOCK_SIZE)) return;
const unsigned char *p = vm_ptr((VM *) vm, addr);
char line[81];
size_t n = 0;
while (n < 80 && n < BLOCK_SIZE) {
unsigned char ch = p[n];
if (ch == 0 || ch == '\n' || ch == '\r') break;
line[n++] = (ch < 32 || ch > 126) ? ' ' : (char) ch;
}
line[n] = '\0';
fprintf(stderr, " block[%ld]: \"%s\"%s\n", (long) scr, line, (n == 80 ? "..." : ""));
}
/* @brief Dumps the current state of the VM for debugging
* @param vm Pointer to the VM instance to dump
* @param reason Optional string describing the reason for the dump
*/
void vm_debug_dump_state(const VM *vm, const char *reason) {
if (!vm) {
fprintf(stderr, "===== VM STATE DUMP (no VM) [%s] =====\n", reason ? reason : "");
return;
}
unsigned base = dbg_get_base(vm);
cell_t scr = 0;
if ((size_t) vm->scr_addr < (size_t) VM_MEMORY_SIZE) scr = vm->memory[(size_t) vm->scr_addr];
fprintf(stderr, "\n===== VM STATE DUMP ===== [%s]\n", reason ? reason : "");
fprintf(stderr, " mode=%s error=%d\n", mode_str(vm->mode), vm->error);
fprintf(stderr, " HERE=%ld BASE=%u SCR=%ld\n", (long) vm->here, base, (long) scr);
fprintf(stderr, " dsp=%d rsp=%d\n", vm->dsp, vm->rsp);
/* If your VM struct exposes stacks, show top few items (guarded). */
#ifdef DATA_STACK_SIZE
if (vm->stack) {
fprintf(stderr, " DATA(top=%d):", vm->dsp);
int shown = 0;
for (int i = vm->dsp; i >= 0 && shown < 16; --i, ++shown)
fprintf(
stderr, " [%d]=%ld", i, (long) vm->stack[i]);
if (vm->dsp >= 16) fprintf(stderr, " ...");
fprintf(stderr, "\n");
}
#endif
#ifdef RETURN_STACK_SIZE
if (vm->rstack) {
fprintf(stderr, " RETURN(top=%d):", vm->rsp);
int shown = 0;
for (int i = vm->rsp; i >= 0 && shown < 16; --i, ++shown)
fprintf(
stderr, " [%d]=%ld", i, (long) vm->rstack[i]);
if (vm->rsp >= 16) fprintf(stderr, " ...");
fprintf(stderr, "\n");
}
#endif
/* If you track current word/ip, print them (guard with your flags/macros). */
#ifdef VM_HAS_CURRENT_ENTRY
if (vm->current_executing_entry) fprintf(stderr, " current=%s\n", vm->current_executing_entry->name);
#endif
#ifdef VM_HAS_IP
fprintf(stderr, " ip=%ld\n", (long) vm->ip);
#endif
dump_block_preview(vm, scr);
fprintf(stderr, "===== END VM STATE DUMP =====\n");
}
/** @brief Signal handler for crash debugging
* @param sig Signal number that was caught
*/
static void sig_handler(int sig) {
const char *name = (sig == SIGSEGV) ? "SIGSEGV" : (sig == SIGABRT) ? "SIGABRT" : "SIGNAL";
fprintf(stderr, "\n*** Caught %s ***\n", name);
if (g_vm) vm_debug_dump_state(g_vm, name);
signal(sig, SIG_DFL);
raise(sig);
}
/** @brief Installs signal handlers for crash debugging
* @details Sets up handlers for SIGSEGV and SIGABRT to dump VM state on crash
*/
void vm_debug_install_signal_handlers(void) {
#if defined(__unix__) || defined(__APPLE__)
/* Use sigaction when available */
#ifdef SA_RESETHAND
struct sigaction sa;
memset(&sa, 0, sizeof(sa));
sa.sa_handler = sig_handler;
sigemptyset(&sa.sa_mask);
sa.sa_flags = SA_RESETHAND; /* one-shot: reset to default after firing */
sigaction(SIGSEGV, &sa, NULL);
sigaction(SIGABRT, &sa, NULL);
#else
/* Fallback: plain signal() if SA_RESETHAND isn’t defined */
signal(SIGSEGV, sig_handler);
signal(SIGABRT, sig_handler);
#endif
#else
/* Non-POSIX platforms: best-effort */
signal(SIGSEGV, sig_handler);
signal(SIGABRT, sig_handler);
#endif
}
#endif /* !STARFORTH_MINIMAL */
v3/src/vm_internal.h
+126
View File
@@ -0,0 +1,126 @@
/*
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.
*/
#ifndef STARFORTH_VM_INTERNAL_H
#define STARFORTH_VM_INTERNAL_H
/*
* vm_internal.h - Shared private declarations for VM implementation
*
* This header is ONLY included by VM .c files (vm.c, vm_time.c, vm_bootstrap.c).
* NOT part of the public API.
*/
#include "../include/vm.h"
#include "../include/platform_time.h"
#include <stdint.h>
/* HISTORICAL: this condition also excluded L4RE_TARGET (`&&
* !defined(L4RE_TARGET)`) -- L4Re had no pthreads. L4Re support has been
* removed as an active target. */
#if HEARTBEAT_THREAD_ENABLED
#include <pthread.h>
#define HEARTBEAT_HAS_THREADS 1
#else
#define HEARTBEAT_HAS_THREADS 0
#endif
/* Heartbeat decay batch size */
#define HEARTBEAT_DECAY_BATCH 64u
/* HeartbeatWorker - background thread state for heartbeat */
typedef struct HeartbeatWorker
{
#if HEARTBEAT_HAS_THREADS
pthread_t thread;
#endif
uint64_t tick_ns;
int running;
int stop_requested;
} HeartbeatWorker;
/* ====================== Atomic helpers ======================= */
static inline uint32_t heartbeat_snapshot_index_load(const volatile uint32_t *ptr)
{
#if defined(__GNUC__)
return __atomic_load_n(ptr, __ATOMIC_ACQUIRE);
#else
return *ptr;
#endif
}
static inline void heartbeat_snapshot_index_store(volatile uint32_t *ptr, uint32_t value)
{
#if defined(__GNUC__)
__atomic_store_n(ptr, value, __ATOMIC_RELEASE);
#else
*ptr = value;
#endif
}
/* ====================== Cross-file function declarations ======================= */
/* vm.c (core) - execution spine */
void execute_colon_word(VM *vm);
/* vm_time.c - heartbeat/physics */
void vm_tick(VM *vm);
void vm_tick_window_tuner(VM *vm);
void vm_tick_slope_validator(VM *vm);
void vm_tick_inference_engine(VM *vm);
void vm_heartbeat_run_cycle(VM *vm);
void vm_snapshot_read(const VM *vm, HeartbeatSnapshot *out_snapshot);
void vm_heartbeat_start_thread(VM *vm);
void vm_heartbeat_stop_thread(VM *vm);
void vm_heartbeat_publish_snapshot(VM *vm);
/* vm_bootstrap.c - initialization */
void vm_init(VM *vm);
void vm_cleanup(VM *vm);
/* vm.c (core) - base helpers used by bootstrap */
unsigned vm_get_base(const VM *vm);
void vm_set_base(VM *vm, unsigned b);
#endif /* STARFORTH_VM_INTERNAL_H */
v3/src/vm_time.c
+796
View File
@@ -0,0 +1,796 @@
/*
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.
*/
/*
* vm_time.c - Heartbeat, timers, entropy/heat tracking, decay
*
* Time is a first-class liar — isolated here to keep the James Law
* machinery from infecting everything else.
*
* Contains:
* - heartbeat logic
* - timers
* - entropy / heat tracking
* - decay / accumulation
* - any "tick" based logic
*/
#include "vm_internal.h"
#include "../include/inference_engine.h"
#include "../include/log.h"
#include "../include/physics_metadata.h"
#include "../include/physics_hotwords_cache.h"
#include "../include/rolling_window_of_truth.h"
#include "../include/dictionary_heat_optimization.h"
#include "../include/ssm_jacquard.h"
#include "../include/platform_alloc.h"
#include <string.h>
#include <errno.h>
#include <time.h>
/* ====================== Forward Declarations ======================= */
static void vm_tick_apply_background_decay(VM *vm, uint64_t now_ns);
static void vm_heartbeat_update_l8(VM *vm);
#if HEARTBEAT_THREAD_ENABLED
static void* heartbeat_thread_main(void *arg);
#endif
/* ====================== Snapshot Publishing ======================= */
void vm_heartbeat_publish_snapshot(VM *vm)
{
if (!vm)
return;
uint32_t current = heartbeat_snapshot_index_load(&vm->heartbeat.snapshot_index) & 1u;
uint32_t next = current ^ 1u;
HeartbeatSnapshot *snapshot = &vm->heartbeat.snapshots[next];
snapshot->published_tick = vm->heartbeat.tick_count;
snapshot->published_ns = sf_monotonic_ns();
snapshot->window_width = vm->rolling_window.effective_window_size;
snapshot->actual_window_size = (uint32_t)(vm->rolling_window.total_executions < ROLLING_WINDOW_SIZE
? vm->rolling_window.total_executions
: ROLLING_WINDOW_SIZE);
snapshot->decay_slope_q48 = vm->decay_slope_q48;
snapshot->hot_word_count = vm->hot_word_count_at_check;
snapshot->stale_word_count = vm->stale_word_count_at_check;
snapshot->total_heat = vm->total_heat_at_last_check;
heartbeat_snapshot_index_store(&vm->heartbeat.snapshot_index, next);
}
/* ====================== VM Heartbeat (Time-Driven Tuning) ======================= */
/**
* @brief Central heartbeat dispatcher for time-driven tuning operations
*
* Aggregates all periodic optimization tasks (Loop #3 and Loop #5) into one place.
* Designed as plugin architecture - new tuning operations can be added as plugins.
*
* Options for integration:
* - Synchronous (now): Called from main execution loop, every N executions
* - Background thread (future): Runs in separate thread, decoupled from VM execution
*
* @param vm Pointer to VM instance
*/
void vm_tick(VM* vm)
{
if (!vm || !vm->heartbeat.heartbeat_enabled)
return;
vm->heartbeat.tick_count++;
/* Unified Inference Engine (Phase 2: Replaces Loops #3 & #5)
* Runs every HEARTBEAT_INFERENCE_FREQUENCY ticks to infer optimal:
* - Window width (via variance inflection detection)
* - Decay slope (via exponential regression on heat trajectory)
*/
if ((vm->heartbeat.tick_count - vm->heartbeat.last_inference_tick) >= HEARTBEAT_INFERENCE_FREQUENCY)
{
vm_tick_inference_engine(vm);
}
/* Plugin 2: System State Monitoring (Future) */
/* vm_tick_system_monitor(vm); */
/* Plugin 3: Formal Verification State Update (Future) */
/* vm_tick_formal_state_sync(vm); */
}
/**
* @brief Loop #5: Context-aware window tuning via binary chop search
*
* Uses prefetch accuracy to guide window size adaptation.
* Binary search converges on optimal effective_window_size for current workload.
*
* @param vm Pointer to VM instance
*/
void vm_tick_window_tuner(VM* vm)
{
if (!vm || !vm->rolling_window.is_warm || !ENABLE_PIPELINING)
return;
RollingWindowOfTruth *window = &vm->rolling_window;
PipelineGlobalMetrics *metrics = &vm->pipeline_metrics;
/* Calculate current prefetch accuracy */
if (metrics->prefetch_attempts == 0)
return; /* Not enough data yet */
double current_accuracy = (double)metrics->prefetch_hits / (double)metrics->prefetch_attempts;
/* Binary chop suggests next window size to try */
uint32_t suggested_size = window->effective_window_size; /* Default: no change */
if (metrics->window_tuning_checks == 0)
{
/* First check: try shrinking by 25% */
suggested_size = (window->effective_window_size * 75) / 100;
}
else
{
/* Compare current accuracy to last check */
double accuracy_delta = current_accuracy - metrics->last_checked_accuracy;
if (accuracy_delta > 0.01) /* Improvement threshold: 1% */
{
/* Accuracy improved! Try shrinking more */
uint32_t smaller = (window->effective_window_size * 75) / 100;
suggested_size = (smaller > ADAPTIVE_MIN_WINDOW_SIZE) ? smaller : ADAPTIVE_MIN_WINDOW_SIZE;
}
else if (accuracy_delta < -0.01)
{
/* Accuracy degraded. Try growing instead */
uint32_t larger = (window->effective_window_size * 133) / 100; /* Grow by ~33% */
suggested_size = (larger < ROLLING_WINDOW_SIZE) ? larger : ROLLING_WINDOW_SIZE;
}
/* else: Plateau, stick with current size */
}
/* Apply if different */
if (suggested_size != window->effective_window_size)
{
log_message(LOG_DEBUG,
"HEARTBEAT[window]: %u → %u (accuracy %.2f%%, %lu/%lu prefetch hits)",
window->effective_window_size,
suggested_size,
current_accuracy * 100.0,
metrics->prefetch_hits,
metrics->prefetch_attempts);
window->effective_window_size = suggested_size;
}
/* Record for next iteration */
metrics->last_checked_window_size = window->effective_window_size;
metrics->last_checked_accuracy = current_accuracy;
metrics->window_tuning_checks++;
}
/**
* @brief Loop #3: Heat decay slope validation via periodic measurement
*
* Validates that linear decay is actually helping optimize dictionary caching.
* Measures stale word ratio, hot word count, and average heat distribution.
*
* @param vm Pointer to VM instance
*/
void vm_tick_slope_validator(VM* vm)
{
if (!vm)
return;
/* Collect snapshot of current state */
uint64_t hot_word_count = 0;
uint64_t stale_word_count = 0;
uint64_t total_heat = 0;
uint32_t word_count = 0;
/* Scan dictionary and categorize words by heat level */
sf_mutex_lock(&vm->dict_lock);
for (DictEntry *e = vm->latest; e != NULL; e = e->link)
{
if (e->execution_heat > HOTWORDS_EXECUTION_HEAT_THRESHOLD)
hot_word_count++;
else if (e->execution_heat > 0 && e->execution_heat < 10)
stale_word_count++;
total_heat += e->execution_heat;
word_count++;
}
sf_mutex_unlock(&vm->dict_lock);
double avg_heat = (word_count > 0) ? (double)total_heat / (double)word_count : 0.0;
double stale_ratio = (word_count > 0) ? (double)stale_word_count / (double)word_count : 0.0;
/* === LOOP #3: INFERENCE ENGINE ===
* Compare current measurements to baseline from last check
* Decide whether decay is too fast, too slow, or optimal
*/
int new_slope_direction = 0; /* -1: decrease slope, 0: stable, +1: increase slope */
sf_mutex_lock(&vm->tuning_lock);
if (vm->word_count_at_check > 0)
{
/* Calculate trend in stale words: absolute count delta indicates accumulation/clearing */
int64_t stale_delta = (int64_t)stale_word_count - (int64_t)vm->stale_word_count_at_check;
/* INFERENCE: If stale words INCREASING, decay is too slow → increase slope */
/* If stale words DECREASING, decay is working (or too fast) → monitor */
if (stale_delta > 5) /* Threshold: 5+ additional stale words signals problem */
{
/* Stale words accumulating: decay is insufficient */
new_slope_direction = 1;
log_message(LOG_DEBUG,
"HEARTBEAT[slope]: stale_delta=%ld, decay TOO SLOW, increase slope",
(long)stale_delta);
}
else if (stale_delta < -5) /* Threshold: 5+ fewer stale words signals clearing */
{
/* Stale words clearing: decay is aggressive (potentially too fast) */
/* Only decrease slope if avg_heat is dropping below target */
if (avg_heat < 5.0)
{
new_slope_direction = -1;
log_message(LOG_DEBUG,
"HEARTBEAT[slope]: stale_delta=%ld, avg_heat=%.1f, decay TOO FAST, decrease slope",
(long)stale_delta, avg_heat);
}
else
{
log_message(LOG_DEBUG,
"HEARTBEAT[slope]: stale_delta=%ld, decay working, hold slope",
(long)stale_delta);
}
}
else
{
log_message(LOG_DEBUG,
"HEARTBEAT[slope]: stale_delta=%ld (stable), hold slope",
(long)stale_delta);
}
}
else
{
log_message(LOG_DEBUG,
"HEARTBEAT[slope]: baseline measurement - hot_words=%lu, stale_ratio=%.2f%%, avg_heat=%.1f",
hot_word_count,
stale_ratio * 100.0,
avg_heat);
}
/* === APPLY SLOPE ADJUSTMENT ===
* Only adjust if direction changed (hysteresis to prevent oscillation)
*/
if (new_slope_direction != vm->decay_slope_direction && new_slope_direction != 0)
{
vm->decay_slope_direction = new_slope_direction;
/* Calculate adjustment in Q48.16: 5% change per cycle */
uint64_t adjustment = (vm->decay_slope_q48 * 5) / 100;
if (adjustment < 1) adjustment = 1; /* Minimum increment */
uint64_t old_slope = vm->decay_slope_q48;
if (new_slope_direction > 0)
{
vm->decay_slope_q48 += adjustment;
}
else if (new_slope_direction < 0)
{
vm->decay_slope_q48 = (vm->decay_slope_q48 > adjustment)
? (vm->decay_slope_q48 - adjustment)
: 1; /* Floor at 1 */
}
/* Log the adjustment as human-readable double */
double old_slope_dbl = (double)old_slope / 65536.0;
double new_slope_dbl = (double)vm->decay_slope_q48 / 65536.0;
log_message(LOG_DEBUG,
"HEARTBEAT[slope]: ADJUSTED slope from %.3f to %.3f (direction=%d)",
old_slope_dbl,
new_slope_dbl,
new_slope_direction);
}
/* Store baseline for next comparison */
vm->hot_word_count_at_check = hot_word_count;
vm->total_heat_at_last_check = total_heat;
vm->stale_word_count_at_check = stale_word_count;
vm->word_count_at_check = word_count;
sf_mutex_unlock(&vm->tuning_lock);
(void)stale_ratio; /* Suppress unused warning */
}
static void vm_tick_apply_background_decay(VM *vm, uint64_t now_ns)
{
if (!vm)
return;
sf_mutex_lock(&vm->dict_lock);
DictEntry *cursor = NULL;
if (vm->heartbeat_decay_cursor_id != WORD_ID_INVALID)
cursor = vm_dictionary_lookup_by_word_id(vm, vm->heartbeat_decay_cursor_id);
if (!cursor)
cursor = vm->latest;
size_t processed = 0;
while (cursor && processed < HEARTBEAT_DECAY_BATCH)
{
/* Tick-based, not wall-clock -- see physics_metadata_apply_linear_decay().
* now_ns is kept only to refresh last_decay_ns for diagnostics. */
uint64_t elapsed_ticks = vm->heartbeat.tick_count - cursor->physics.last_decay_tick;
physics_metadata_apply_linear_decay(cursor, elapsed_ticks, vm);
cursor->physics.last_decay_tick = vm->heartbeat.tick_count;
cursor->physics.last_decay_ns = now_ns;
cursor = cursor->link;
processed++;
}
vm->heartbeat_decay_cursor_id = (cursor && cursor->word_id != WORD_ID_INVALID)
? cursor->word_id
: WORD_ID_INVALID;
sf_mutex_unlock(&vm->dict_lock);
}
/**
* @brief L8 FINAL INTEGRATION: Jacquard mode selector heartbeat update
*
* Collects metrics from L1-L7 physics layers and feeds them to the L8 Jacquard
* mode selector. L8 then chooses the optimal configuration mode based on workload
* characteristics and applies it to the runtime.
*
* This is the SOLE policy engine - all adaptive decisions flow through L8.
*
* @param vm Pointer to VM instance
*/
static void vm_heartbeat_update_l8(VM *vm)
{
if (!vm || !vm->ssm_l8_state)
return;
ssm_l8_state_t *l8 = (ssm_l8_state_t*)vm->ssm_l8_state;
/* === Collect L1-L7 Metrics and Convert to L8 Format === */
ssm_l8_metrics_t metrics = {0};
/* L2: Rolling window entropy (normalized diversity) */
/* Use unique word count / total executions as entropy proxy */
uint32_t unique_words = (vm->rolling_window.total_executions > 0) ?
(uint32_t)(vm->rolling_window.effective_window_size) : 0;
metrics.entropy = (double)unique_words / (double)(ROLLING_WINDOW_SIZE > 0 ? ROLLING_WINDOW_SIZE : 1);
/* L4: Pipelining metrics → CV (coefficient of variation) */
if (vm->pipeline_metrics.prefetch_attempts > 0) {
double accuracy = (double)vm->pipeline_metrics.prefetch_hits / (double)vm->pipeline_metrics.prefetch_attempts;
metrics.cv = 1.0 - accuracy; /* Invert: high accuracy = low CV (stability) */
} else {
metrics.cv = 0.5; /* Default moderate CV if no data */
}
/* L3: Decay slope → temporal locality signal (Q48.16 → double) */
double decay_slope = (double)vm->decay_slope_q48 / 65536.0;
metrics.temporal_decay = (decay_slope > 0.0) ? (1.0 / decay_slope) : 0.0; /* Higher slope = stronger temporal locality */
if (metrics.temporal_decay > 1.0) metrics.temporal_decay = 1.0; /* Clamp to [0,1] */
/* L5/L6: Inference stability for hysteresis + table ANOVA tracking */
{
int early_exited;
sf_mutex_lock(&vm->tuning_lock);
early_exited = (vm->last_inference_outputs && vm->last_inference_outputs->early_exited);
sf_mutex_unlock(&vm->tuning_lock);
metrics.stability_score = early_exited ? 0.9 : 0.1;
metrics.inference_early_exited = early_exited;
/* Inference ran this tick if last_inference_tick == tick_count */
metrics.inference_ran_this_tick =
(vm->heartbeat.tick_count == vm->heartbeat.last_inference_tick) ? 1 : 0;
}
if (l8->table) {
/* === Adaptive table-based selection === */
uint8_t old_config = l8->table->current_config;
CDTuning cd_tuning = cd_tuning_word();
uint32_t recent_ids[CD_MAX_CLASSIFY_DEPTH];
uint32_t recent_count = rolling_window_get_recent_sequence(
&vm->rolling_window, cd_tuning.id_window_depth, recent_ids);
ssm_l8_update_table(l8, &metrics,
(ssm_config_t*)vm->ssm_config,
vm->rolling_window.effective_window_size,
recent_ids, recent_count);
if (l8->table->current_config != old_config) {
uint8_t bits = l8->table->entries[l8->table->current_config].config_bits;
ssm_config_t *cfg = (ssm_config_t*)vm->ssm_config;
log_message(LOG_DEBUG,
"L8[TABLE]: Config %u → %u regime=%u score=%u "
"L1=%d L2=%d L3=%d L4=%d L5=%d L6=%d L7=%d",
(unsigned)old_config,
(unsigned)l8->table->current_config,
(unsigned)l8->table->current_regime,
(unsigned)l8->table->regime_scores
[l8->table->current_regime * l8->table->num_configs
+ l8->table->current_config],
cfg->L1_heat_tracking, cfg->L2_rolling_window,
cfg->L3_linear_decay, cfg->L4_pipelining,
cfg->L5_window_inference, cfg->L6_decay_inference,
cfg->L7_adaptive_heartrate);
(void)bits;
}
} else {
/* === Legacy threshold classifier === */
ssm_l8_mode_t old_mode = l8->current_mode;
ssm_l8_update(&metrics, l8);
if (l8->current_mode != old_mode) {
ssm_config_t *config = (ssm_config_t*)vm->ssm_config;
ssm_apply_mode(l8, config);
log_message(LOG_DEBUG,
"L8[JACQUARD]: Mode %s → %s (entropy=%.2f, cv=%.2f, temporal=%.2f)",
ssm_l8_mode_name(old_mode),
ssm_l8_mode_name(l8->current_mode),
metrics.entropy,
metrics.cv,
metrics.temporal_decay);
}
}
/* L1's cache->enabled is the runtime toggle physics_pre_execute's
* hotwords-cache checks actually read (see physics_execution_hooks.c);
* sync it here rather than re-deriving ssm_config on the hot dispatch
* path every word execution. Idempotent -- cheap even when unchanged. */
if (vm->hotwords_cache && vm->ssm_config) {
hotwords_cache_set_enabled(vm->hotwords_cache,
((ssm_config_t*)vm->ssm_config)->L1_heat_tracking);
}
}
void vm_heartbeat_run_cycle(VM *vm)
{
if (!vm || !vm->heartbeat.heartbeat_enabled)
return;
/* L8 FINAL INTEGRATION: Core heartbeat operations */
vm_tick(vm);
vm_tick_apply_background_decay(vm, sf_monotonic_ns());
rolling_window_service(&vm->rolling_window);
dict_adaptive_optimization_pass(vm); /* Adaptive dictionary optimization */
/* L8 FINAL INTEGRATION: Jacquard mode selector - the sole policy engine */
vm_heartbeat_update_l8(vm);
vm_heartbeat_publish_snapshot(vm);
/* Phase 2: Real-time heartbeat metrics emission (DISABLED)
* Re-enable with --heartbeat-log=full or add a runtime flag.
*/
#if 0
HeartbeatTickSnapshot tick_snapshot;
heartbeat_capture_tick_snapshot(vm, &tick_snapshot);
heartbeat_emit_tick_row(vm, &tick_snapshot);
#endif
}
#if HEARTBEAT_THREAD_ENABLED
static void* heartbeat_thread_main(void *arg)
{
VM *vm = (VM*)arg;
if (!vm || !vm->heartbeat.worker)
return NULL;
HeartbeatWorker *worker = vm->heartbeat.worker;
worker->running = 1;
/* IMPORTANT: No startup delay to allow heartbeat to emit during short DoE runs.
* Original 50ms delay avoided race conditions during word registration, but prevented
* real-time metrics emission in fast-completing tests. */
while (!worker->stop_requested)
{
vm_heartbeat_run_cycle(vm);
uint64_t tick_ns = worker->tick_ns ? worker->tick_ns : HEARTBEAT_TICK_NS;
struct timespec req;
req.tv_sec = (time_t)(tick_ns / 1000000000ULL);
req.tv_nsec = (long)(tick_ns % 1000000000ULL);
while (!worker->stop_requested && nanosleep(&req, &req) == -1 && errno == EINTR)
{
/* Retry with remaining time */
}
}
worker->running = 0;
return NULL;
}
#endif
void vm_snapshot_read(const VM* vm, HeartbeatSnapshot* out_snapshot)
{
if (!vm || !out_snapshot)
return;
uint32_t index = heartbeat_snapshot_index_load(&vm->heartbeat.snapshot_index) & 1u;
*out_snapshot = vm->heartbeat.snapshots[index];
}
/**
* @brief Phase 2: Unified Inference Engine - Adaptive Window & Decay Slope Tuning
*
* Coordinates inference on rolling window of truth to determine:
* - Optimal adaptive window width (via variance inflection detection)
* - Optimal decay slope (via exponential regression on heat trajectory)
*
* Uses ANOVA early-exit to skip full inference when variance is stable (<5% change).
* All math uses Q48.16 fixed-point (integer-only, no floating-point).
*
* Replaces legacy vm_tick_window_tuner() and vm_tick_slope_validator().
*
* @param vm Pointer to VM instance
*/
void vm_tick_inference_engine(VM* vm)
{
if (!vm || !vm->heartbeat.heartbeat_enabled || !vm->rolling_window.is_warm)
return;
/* DoE counter: inference engine invocations */
vm->heartbeat.inference_run_count++;
rolling_window_service(&vm->rolling_window);
/* Allocate InferenceOutputs if needed - protect with tuning_lock against race with doe_metrics */
sf_mutex_lock(&vm->tuning_lock);
if (!vm->last_inference_outputs)
{
vm->last_inference_outputs = sf_malloc(sizeof(InferenceOutputs));
if (!vm->last_inference_outputs)
{
sf_mutex_unlock(&vm->tuning_lock);
log_message(LOG_ERROR, "INFERENCE: Failed to allocate InferenceOutputs");
return;
}
memset(vm->last_inference_outputs, 0, sizeof(InferenceOutputs));
}
sf_mutex_unlock(&vm->tuning_lock);
/* === Collect Current Dictionary Metrics === */
uint64_t hot_word_count = 0;
uint64_t stale_word_count = 0;
uint64_t total_heat = 0;
uint32_t word_count = 0;
sf_mutex_lock(&vm->dict_lock);
for (DictEntry *e = vm->latest; e != NULL; e = e->link)
{
if (e->execution_heat > HOTWORDS_EXECUTION_HEAT_THRESHOLD)
hot_word_count++;
else if (e->execution_heat > 0 && e->execution_heat < 10)
stale_word_count++;
total_heat += e->execution_heat;
word_count++;
}
sf_mutex_unlock(&vm->dict_lock);
/* === Populate InferenceInputs === */
InferenceInputs inference_inputs = {
.window = &vm->rolling_window,
.vm = vm, /* Required for dictionary lookups in extract_heat_trajectory */
.trajectory_length = (vm->rolling_window.window_pos > 0)
? vm->rolling_window.window_pos
: vm->rolling_window.total_executions,
.prefetch_hits = vm->pipeline_metrics.prefetch_hits,
.prefetch_attempts = vm->pipeline_metrics.prefetch_attempts,
.hot_word_count = hot_word_count,
.stale_word_count = stale_word_count,
.total_heat = total_heat,
.word_count = word_count,
.last_total_heat = vm->total_heat_at_last_check,
.last_stale_count = vm->stale_word_count_at_check
};
/* === Run Unified Inference Engine === */
inference_engine_run(&inference_inputs, vm->last_inference_outputs);
/* === Apply Inferred Tuning Parameters === */
if (!vm->last_inference_outputs->early_exited)
{
/* Full inference was executed (not cached by ANOVA early-exit) */
/* 1. Apply adaptive window width */
if (vm->last_inference_outputs->adaptive_window_width > 0 &&
vm->last_inference_outputs->adaptive_window_width != vm->rolling_window.effective_window_size)
{
log_message(LOG_DEBUG,
"INFERENCE[window]: %u → %u (variance=%.6f Q48.16)",
vm->rolling_window.effective_window_size,
vm->last_inference_outputs->adaptive_window_width,
(double)vm->last_inference_outputs->window_variance_q48 / 65536.0);
vm->rolling_window.effective_window_size = vm->last_inference_outputs->adaptive_window_width;
}
/* 2. Apply adaptive decay slope */
sf_mutex_lock(&vm->tuning_lock);
if (vm->last_inference_outputs->adaptive_decay_slope > 0 &&
vm->last_inference_outputs->adaptive_decay_slope != vm->decay_slope_q48)
{
double old_slope_dbl = (double)vm->decay_slope_q48 / 65536.0;
double new_slope_dbl = (double)vm->last_inference_outputs->adaptive_decay_slope / 65536.0;
log_message(LOG_DEBUG,
"INFERENCE[slope]: %.3f → %.3f (fit_quality=%.6f Q48.16)",
old_slope_dbl,
new_slope_dbl,
(double)vm->last_inference_outputs->slope_fit_quality_q48 / 65536.0);
vm->decay_slope_q48 = vm->last_inference_outputs->adaptive_decay_slope;
}
sf_mutex_unlock(&vm->tuning_lock);
/* 3. Validate outputs */
if (!inference_outputs_validate(vm->last_inference_outputs))
{
/* 2026-09-22: downgraded from LOG_WARN, matching the kernel
* copy of this logic (src/starkernel/vm/vm_runtime.c) --
* fires routinely during normal operation and the runtime
* self-recovers every time (the whole point of "ignoring
* results"), so it does not warrant default-visible
* attention. Still available with --log-level=info/debug. */
log_message(LOG_INFO,
"INFERENCE: Output validation failed, ignoring results");
}
vm->heartbeat.last_inference_tick = vm->heartbeat.tick_count;
}
else
{
/* ANOVA early-exit: variance stable, using cached outputs */
vm->heartbeat.early_exit_count++;
log_message(LOG_DEBUG,
"INFERENCE: Early-exit (variance stable <5%%), using cached outputs");
}
/* Store baseline for next inference comparison */
sf_mutex_lock(&vm->tuning_lock);
vm->total_heat_at_last_check = total_heat;
vm->stale_word_count_at_check = stale_word_count;
vm->word_count_at_check = word_count;
sf_mutex_unlock(&vm->tuning_lock);
/* L8 FINAL INTEGRATION: Loop always-on */ /* === Loop #7: Adaptive Heartrate ===
* Adjust tick frequency based on system stability:
* - Variance stable (early_exited) → increase tick interval (less frequent)
* - Variance volatile (full inference) → decrease tick interval (more frequent)
*
* Bounds: [HEARTBEAT_TICK_NS / 4, HEARTBEAT_TICK_NS * 4]
*/
{
uint64_t current_tick_ns = vm->heartbeat.tick_target_ns;
uint64_t min_tick_ns = HEARTBEAT_TICK_NS / 4; /* 4x faster minimum */
uint64_t max_tick_ns = HEARTBEAT_TICK_NS * 4; /* 4x slower maximum */
if (vm->last_inference_outputs && vm->last_inference_outputs->early_exited)
{
/* System stable: slow down heartbeat by 25% */
uint64_t new_tick_ns = (current_tick_ns * 125) / 100;
if (new_tick_ns > max_tick_ns) new_tick_ns = max_tick_ns;
if (new_tick_ns != current_tick_ns)
{
vm->heartbeat.tick_target_ns = new_tick_ns;
if (vm->heartbeat.worker)
vm->heartbeat.worker->tick_ns = new_tick_ns;
log_message(LOG_DEBUG,
"HEARTBEAT[rate]: stable → slower tick %lu → %lu ns",
(unsigned long)current_tick_ns,
(unsigned long)new_tick_ns);
}
}
else
{
/* System volatile: speed up heartbeat by 25% */
uint64_t new_tick_ns = (current_tick_ns * 80) / 100;
if (new_tick_ns < min_tick_ns) new_tick_ns = min_tick_ns;
if (new_tick_ns != current_tick_ns)
{
vm->heartbeat.tick_target_ns = new_tick_ns;
if (vm->heartbeat.worker)
vm->heartbeat.worker->tick_ns = new_tick_ns;
log_message(LOG_DEBUG,
"HEARTBEAT[rate]: volatile → faster tick %lu → %lu ns",
(unsigned long)current_tick_ns,
(unsigned long)new_tick_ns);
}
}
}
/* End always-on loop */}
/* ====================== Thread Start/Stop Wrappers ======================= */
void vm_heartbeat_start_thread(VM *vm)
{
#if HEARTBEAT_HAS_THREADS
if (!vm)
return;
vm->heartbeat.worker = sf_calloc(1, sizeof(HeartbeatWorker));
if (vm->heartbeat.worker)
{
vm->heartbeat.worker->tick_ns = HEARTBEAT_TICK_NS;
if (pthread_create(&vm->heartbeat.worker->thread, NULL, heartbeat_thread_main, vm) != 0)
{
log_message(LOG_WARN, "heartbeat: pthread_create failed (%d), falling back to inline mode", errno);
sf_free(vm->heartbeat.worker);
vm->heartbeat.worker = NULL;
}
}
else
{
log_message(LOG_WARN, "heartbeat: worker allocation failed, using inline heartbeat");
}
#else
(void)vm;
#endif
}
void vm_heartbeat_stop_thread(VM *vm)
{
#if HEARTBEAT_HAS_THREADS
if (!vm || !vm->heartbeat.worker)
return;
vm->heartbeat.worker->stop_requested = 1;
pthread_join(vm->heartbeat.worker->thread, NULL);
sf_free(vm->heartbeat.worker);
vm->heartbeat.worker = NULL;
#else
(void)vm;
#endif
}
v3/src/word_registry.c
+155
View File
@@ -0,0 +1,155 @@
/*
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/word_registry.h"
#include "../include/log.h"
#include <string.h>
/* Include all FORTH-79 word module headers + extensions */
#include "word_source/include/acl_words.h"
#include "word_source/include/stack_words.h"
#include "word_source/include/return_stack_words.h"
#include "word_source/include/memory_words.h"
#include "word_source/include/dictionary_words.h"
#include "word_source/include/arithmetic_words.h"
#include "word_source/include/double_words.h"
#include "word_source/include/mixed_arithmetic_words.h"
#include "word_source/include/logical_words.h"
#include "word_source/include/io_words.h"
#include "word_source/include/format_words.h"
#include "word_source/include/string_words.h"
#include "word_source/include/control_words.h"
#include "word_source/include/defining_words.h"
#include "word_source/include/dictionary_manipulation_words.h"
#include "word_source/include/vocabulary_words.h"
#include "word_source/include/block_words.h"
#include "word_source/include/editor_words.h"
#include "word_source/include/system_words.h"
#include "word_source/include/starforth_words.h"
#include "word_source/include/physics_benchmark_words.h"
#include "word_source/include/physics_pipelining_diagnostic_words.h"
#include "word_source/include/physics_freeze_words.h"
#include "word_source/include/dictionary_heat_diagnostic_words.h"
#include "word_source/include/log_words.h"
#include "word_source/include/q48_words.h"
#include "word_source/include/inference_words.h"
#include "word_source/include/defer_words.h"
#include "word_source/include/framebuffer_words.h"
#include "word_source/include/keyboard_words.h"
#include "word_source/include/ttf_words.h"
#include "word_source/include/scroll_words.h"
#ifdef __STARKERNEL__
#include "starkernel/doe_log.h"
#include "starkernel/repl.h"
#endif
/**
* @brief Registers a single FORTH word in the virtual machine
* @param vm Pointer to the virtual machine instance
* @param name Name of the FORTH word to register
* @param func Function pointer to the word's implementation
*/
void register_word(VM *vm, const char *name, word_func_t func) {
DictEntry *entry = vm_create_word(vm, name, strlen(name), func);
if (entry) {
log_message(LOG_DEBUG, "Registered word: %s", name);
} else {
log_message(LOG_ERROR, "Failed to register word: %s", name);
}
}
/**
* @brief Registers all standard FORTH-79 words in the virtual machine
* @param vm Pointer to the virtual machine instance
* @details Registers all 18 FORTH-79 word modules in dependency order,
* starting with fundamental stack operations and building up to
* more complex functionality like control flow and editing.
*/
void register_forth79_words(VM *vm) {
log_message(LOG_INFO, "Registering FORTH-79 Standard word set...");
/* Register all 18 FORTH-79 word modules IN DEPENDENCY ORDER */
register_stack_words(vm); /* Module 1: Stack Operations - FOUNDATION */
register_return_stack_words(vm); /* Module 2: Return Stack Operations */
register_memory_words(vm); /* Module 3: Memory Operations */
register_arithmetic_words(vm); /* Module 4: Arithmetic Operations */
register_logical_words(vm); /* Module 5: Logical & Comparison */
register_mixed_arithmetic_words(vm); /* Module 6: Mixed Arithmetic - needs arithmetic + stack */
register_double_words(vm); /* Module 7: Double Number Arithmetic */
register_format_words(vm); /* Module 8: Formatting & Conversion */
register_string_words(vm); /* Module 9: String & Text Processing */
register_io_words(vm); /* Module 10: I/O & Terminal */
register_block_words(vm); /* Module 11: Block & Mass Storage */
register_dictionary_words(vm); /* Module 12: Dictionary & Compilation */
register_dictionary_manipulation_words(vm); /* Module 13: Dictionary Manipulation */
register_vocabulary_words(vm); /* Module 14: Vocabulary System */
register_system_words(vm); /* Module 15: System & Environment */
register_editor_words(vm); /* Module 16: Line Editor */
register_defining_words(vm); /* Module 17: Defining Words */
register_control_words(vm); /* Module 18: Control Flow */
register_starforth_words(vm); /* Module 19: StarForth Implementation Extensions */
register_acl_words(vm); /* Module 20: Word-Level ACL System */
register_physics_benchmark_words(vm); /* Module 21: Physics Benchmark Words */
register_physics_pipelining_diagnostic_words(vm); /* Module 21: Pipelining Diagnostics */
register_physics_freeze_words(vm); /* Module 22: Phase 2 Freeze/Decay Control Words */
register_dictionary_heat_diagnostic_words(vm); /* Module 23: Dictionary Heat Optimization */
register_log_words(vm); /* Module 24: Log Level Control */
register_q48_words(vm); /* Module 25: Q48.16 Fixed-Point Math */
register_inference_words(vm); /* Module 26: SSM Inference + Jacquard */
register_defer_words(vm); /* Module 27: DEFER / IS late binding */
/* Module 28 (PLOT/FB-WIDTH/FB-HEIGHT, framebuffer_words.c) deliberately
* NOT registered here -- FABRIC-3.6.md task 1.8 (item 33): every VM got
* these unconditionally before this change (confirmed live, task 0.8 --
* Hermes and Artemis could both call FB-WIDTH despite never loading
* fabric.4th). Hestia is now the sole owner; see the name-gated call in
* capsule_birth_baby() (capsule_birth.c), the only place a VM's name is
* known at the point its dictionary is built. */
register_keyboard_words(vm); /* Module 29: Console fabric -- raw keyboard scancode diagnostic */
register_ttf_words(vm); /* Module 30: TrueType text entry point */
register_scroll_words(vm); /* Module 31: REPL scrollback (FABRIC-0.md 4.4q) */
#ifdef __STARKERNEL__
register_doe_log_words(vm); /* Module 32: DoE instrumentation runtime toggle (HB-ON/HB-OFF) */
sk_repl_register_words(vm); /* Module 33: BLK-ATTACH-ACK, Artemis's storage-attach reply target */
#endif
log_message(LOG_INFO, "FORTH-79 Standard word set registration complete");
}
v3/src/word_source/README.md
+51
View File
@@ -0,0 +1,51 @@
# src/word_source/
FORTH-79 word implementations, one file per category, registered into the
dictionary via `include/word_registry.h`. Each `.c` file here has a
matching header in `src/word_source/include/` and (for most categories) a
matching test module in `src/test_runner/modules/`.
**FORTH-79 core**
- `arithmetic_words.c`, `mixed_arithmetic_words.c` — `+ - * / MOD ABS MIN
MAX` and mixed-precision arithmetic.
- `stack_words.c` — `DUP DROP SWAP ROT OVER NIP TUCK`.
- `control_words.c` — `IF ELSE THEN DO LOOP BEGIN UNTIL WHILE`.
- `defining_words.c` — `: ; CREATE DOES> VARIABLE CONSTANT`.
- `memory_words.c` — `@ ! C@ C! MOVE FILL`.
- `return_stack_words.c` — `>R R> R@ RDROP 2>R 2R@ 2R>`.
- `double_words.c` — `2DUP 2DROP 2SWAP 2@ 2! D+ D-`.
- `logical_words.c` — `AND OR XOR NOT INVERT LSHIFT RSHIFT`.
- `io_words.c` — `EMIT KEY TYPE CR TAB SPACE ACCEPT`.
- `string_words.c` — `S" SLITERAL` and other string operations.
- `block_words.c` — `BLOCK BUFFER LOAD THRU FLUSH`.
- `format_words.c` — `.( .R .S HEX DECIMAL BASE`.
- `system_words.c` — `BYE ABORT INCLUDE STATE`.
- `dictionary_words.c` — `FIND SEARCH-WORDLIST WORDS`.
- `dictionary_manipulation_words.c` — dictionary entry manipulation words.
- `vocabulary_words.c` — `VOCABULARY DEFINITIONS FORTH-WORDLIST`.
- `editor_words.c` — block editor words.
- `defer_words.c` — `DEFER`/`IS` deferred-word mechanism, used by the
Tripod message-dispatch shim (see `tools/hermes_tripod_smoke.sh`).
**StarForth-specific extensions**
- `q48_16_words.c`, `q48_words.c` — Q48.16 fixed-point word bindings.
- `starforth_words.c` — StarForth-specific extensions.
- `acl_words.c` — word-level ACL system's FORTH-callable primitives (see
`docs/03-architecture/word-acl/`).
- `lifecycle_words_hosted.c` — hosted-build VM lifecycle words (birth/run
primitives on the hosted side; kernel-only primitives live in
`src/starkernel/capsule/mama_forth_words.c`).
- `log_words.c` — FORTH-callable logging primitives.
- `inference_words.c` — FORTH-callable bindings for the statistical
inference engine (Loops #5/#6).
- `physics_benchmark_words.c` — benchmark harness for the 7 physics
feedback loops.
- `physics_diagnostic_words.c` — physics diagnostics (`WORD-ENTROPY`).
- `physics_freeze_words.c` — `PHYSICS-FREEZE` / `PHYSICS-THAW`.
- `physics_pipelining_diagnostic_words.c` — Loop #4 pipelining
diagnostics.
- `dictionary_heat_diagnostic_words.c` — Loop #1 heat diagnostics.
See `src/word_source/include/` for the matching headers (also includes
`mama_forth_words.h`, whose `.c` implementation lives under
`src/starkernel/capsule/` since it's kernel-only).
v3/src/word_source/acl_words.c
+355
View File
@@ -0,0 +1,355 @@
/*
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.
*/
/*
* acl_words.c — C primitive words for the word-level ACL system
*
* All policy logic lives in capsules/ACL.4th. These primitives expose
* DictEntry ACL fields to FORTH: ACL-MODE@, ACL-MODE!, ACL-PINNED?,
* ACL-PIN, ACL-TTL@, ACL-TTL!, ACL-ALLOW@, ACL-ALLOW!, ACL-HEAT@,
* ACL-INHERIT, ACL-INIT-PRIMITIVES, ACL-WORD-ID.
*
* All words that take an XT expect a DictEntry* cast to cell_t on the
* stack — exactly what ' (tick) produces in StarForth.
*/
#include "include/acl_words.h"
#include "../../include/vm.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
/**
* @brief Pop an execution token (XT) from the data stack and return the
* corresponding DictEntry pointer.
*
* Sets @c vm->error and returns NULL on stack underflow or if the XT is zero.
* All ACL word implementations call this before accessing DictEntry fields.
*
* @param vm Pointer to the VM structure
* @return Pointer to the DictEntry, or NULL on error
*/
static DictEntry *pop_xt(VM *vm)
{
if (!vm || vm->dsp < 0) {
log_message(LOG_ERROR, "ACL word: stack underflow");
if (vm) vm->error = 1;
return NULL;
}
cell_t xt = vm_pop(vm);
DictEntry *entry = (DictEntry *)(uintptr_t)xt;
if (!entry) {
log_message(LOG_ERROR, "ACL word: NULL XT");
vm->error = 1;
return NULL;
}
return entry;
}
/**
* @brief Implements FORTH word @c ACL-MODE@ — fetch ACL enforcement mode
*
* Stack effect: ( xt -- mode )
* Pushes the enforcement mode of the word identified by @c xt:
* 0 = STRICT (allow/deny is permanent), 1 = TTL (expires after countdown).
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_mode_fetch(VM *vm)
{
DictEntry *e = pop_xt(vm);
if (!e) return;
vm_push(vm, (cell_t)e->acl_mode);
}
/**
* @brief Implements FORTH word @c ACL-MODE! — store ACL enforcement mode
*
* Stack effect: ( mode xt -- )
* Sets the enforcement mode of the word identified by @c xt.
* No-op if the word is pinned — pinned entries are immutable.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_mode_store(VM *vm)
{
if (!vm || vm->dsp < 1) {
log_message(LOG_ERROR, "ACL-MODE!: stack underflow");
if (vm) vm->error = 1;
return;
}
DictEntry *e = pop_xt(vm);
if (!e) return;
cell_t mode = vm_pop(vm);
if (e->acl_pinned) return; /* one-way ratchet: pinned is immutable */
e->acl_mode = (uint8_t)(mode & 0xFF);
}
/**
* @brief Implements FORTH word @c ACL-PINNED? — query pin status
*
* Stack effect: ( xt -- flag )
* Pushes -1 (true) if the word is pinned, 0 (false) otherwise.
* A pinned word's ACL fields cannot be modified by any FORTH operation.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_pinned_query(VM *vm)
{
DictEntry *e = pop_xt(vm);
if (!e) return;
vm_push(vm, e->acl_pinned ? -1 : 0);
}
/**
* @brief Implements FORTH word @c ACL-PIN — pin a word's ACL entry
*
* Stack effect: ( xt -- )
* Sets @c acl_pinned = 1 on the word identified by @c xt.
* This is a one-way ratchet: once set it can never be cleared, even by
* ACL-INHERIT. Use with @c ' WORD ACL-PIN in FORTH, never from C policy code.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_pin(VM *vm)
{
DictEntry *e = pop_xt(vm);
if (!e) return;
e->acl_pinned = 1;
}
/**
* @brief Implements FORTH word @c ACL-TTL@ — fetch TTL countdown value
*
* Stack effect: ( xt -- n )
* Pushes the current TTL (time-to-live) countdown of the word's ACL entry.
* When TTL reaches zero in TTL mode the interpreter calls @c acl_recheck().
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_ttl_fetch(VM *vm)
{
DictEntry *e = pop_xt(vm);
if (!e) return;
vm_push(vm, (cell_t)e->acl_ttl);
}
/**
* @brief Implements FORTH word @c ACL-TTL! — store TTL countdown value
*
* Stack effect: ( n xt -- )
* Sets the TTL countdown on the word's ACL entry. Negative values are
* clamped to 0; values above UINT32_MAX are clamped to UINT32_MAX.
* No-op if the word is pinned.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_ttl_store(VM *vm)
{
if (!vm || vm->dsp < 1) {
log_message(LOG_ERROR, "ACL-TTL!: stack underflow");
if (vm) vm->error = 1;
return;
}
DictEntry *e = pop_xt(vm);
if (!e) return;
cell_t n = vm_pop(vm);
if (e->acl_pinned) return;
e->acl_ttl = (uint32_t)(n < 0 ? 0 : (uint64_t)n > UINT32_MAX ? UINT32_MAX : (uint32_t)n);
}
/**
* @brief Implements FORTH word @c ACL-ALLOW@ — fetch cached allow/deny flag
*
* Stack effect: ( xt -- flag )
* Pushes the cached ACL decision for the word: -1 = allowed, 0 = denied.
* This cached value is checked on every execution in TTL mode; the cache is
* refreshed by @c acl_recheck() when TTL expires.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_allow_fetch(VM *vm)
{
DictEntry *e = pop_xt(vm);
if (!e) return;
vm_push(vm, e->acl_allow ? -1 : 0);
}
/**
* @brief Implements FORTH word @c ACL-ALLOW! — store cached allow/deny flag
*
* Stack effect: ( flag xt -- )
* Sets the cached ACL decision: any non-zero @c flag = allowed, 0 = denied.
* No-op if the word is pinned.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_allow_store(VM *vm)
{
if (!vm || vm->dsp < 1) {
log_message(LOG_ERROR, "ACL-ALLOW!: stack underflow");
if (vm) vm->error = 1;
return;
}
DictEntry *e = pop_xt(vm);
if (!e) return;
cell_t flag = vm_pop(vm);
if (e->acl_pinned) return;
e->acl_allow = (flag != 0) ? 1 : 0;
}
/**
* @brief Implements FORTH word @c ACL-HEAT@ — fetch execution heat
*
* Stack effect: ( xt -- heat )
* Pushes the @c execution_heat counter for the word identified by @c xt.
* Used by @c ACL-TTL-COMPUTE in @c ACL.4th to calibrate the TTL value based
* on how frequently the word is executed.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_heat_fetch(VM *vm)
{
DictEntry *e = pop_xt(vm);
if (!e) return;
vm_push(vm, (cell_t)e->execution_heat);
}
/**
* @brief Implements FORTH word @c ACL-WORD-ID — fetch stable word identifier
*
* Stack effect: ( xt -- n )
* Pushes the stable @c word_id for the entry identified by @c xt. Unlike
* dictionary positions, @c word_id is assigned at registration and never
* changes, making it safe to use as a persistent table index in @c ACL.4th.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_word_id(VM *vm)
{
DictEntry *e = pop_xt(vm);
if (!e) return;
vm_push(vm, (cell_t)e->word_id);
}
/**
* @brief Implements FORTH word @c ACL-INHERIT — inherit ACL policy from parent
*
* Stack effect: ( src dst -- )
* Copies @c acl_mode from @c src to @c dst, then clears @c dst->acl_pinned,
* resets @c acl_ttl to 0, and sets @c acl_allow to 1 (optimistic default).
* This is a C primitive because FORTH code cannot clear @c acl_pinned — pin
* is a one-way ratchet that only C can reset during inheritance.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_inherit(VM *vm)
{
if (!vm || vm->dsp < 1) {
log_message(LOG_ERROR, "ACL-INHERIT: stack underflow");
if (vm) vm->error = 1;
return;
}
DictEntry *dst = pop_xt(vm);
if (!dst) return;
DictEntry *src = pop_xt(vm);
if (!src) return;
acl_inherit_entry(src, dst);
}
/**
* @brief Implements FORTH word @c ACL-INIT-PRIMITIVES — reset ACL fields on all
* unpinned dictionary entries
*
* Stack effect: ( -- )
* Walks the entire dictionary and resets ACL fields on every entry that is not
* pinned: sets @c acl_ttl = 0 (force recheck on first execution), @c acl_allow
* = 1 (optimistic default), @c acl_mode = ACL_MODE_TTL. Called by @c ACL-BOOT
* in @c ACL.4th immediately after the ACL capsule finishes loading.
*
* @param vm Pointer to the VM structure
*/
static void forth_acl_init_primitives(VM *vm)
{
if (!vm) return;
for (DictEntry *e = vm->latest; e; e = e->link) {
if (!e->acl_pinned) {
/* Re-assert permissive defaults; ACL-RECHECK will calibrate on first exec */
e->acl_ttl = 0; /* force recheck on first execution */
e->acl_allow = 1;
e->acl_mode = ACL_MODE_TTL;
}
}
}
/**
* @brief Direct C entry point for ACL policy inheritance on the capsule birth path.
*
* Copies @c acl_mode from @c src to @c dst, clears @c acl_pinned, resets
* @c acl_ttl to 0, and sets @c acl_allow to 1. Called from capsule birth code
* (not from FORTH) — no stack manipulation is performed.
*
* @param src Source DictEntry whose @c acl_mode is inherited
* @param dst Destination DictEntry whose ACL fields are updated
*/
void acl_inherit_entry(DictEntry *src, DictEntry *dst)
{
if (!src || !dst) return;
dst->acl_mode = src->acl_mode;
dst->acl_pinned = 0; /* pin is contextual, not viral */
dst->acl_ttl = 0; /* child has no history; force recheck */
dst->acl_allow = 1; /* optimistic default */
}
/**
* @brief Register all ACL C-primitive words with the VM dictionary.
*
* Registers: field accessors (@c ACL-MODE@ / @c ACL-MODE! / @c ACL-PINNED? /
* @c ACL-TTL@ / @c ACL-TTL! / @c ACL-ALLOW@ / @c ACL-ALLOW! / @c ACL-HEAT@ /
* @c ACL-WORD-ID), and mutation words (@c ACL-PIN / @c ACL-INHERIT /
* @c ACL-INIT-PRIMITIVES). Called from @c vm_bootstrap.c during VM
* initialisation.
*
* @param vm Pointer to the VM structure
*/
void register_acl_words(VM *vm)
{
/* Field accessors — read */
register_word(vm, "ACL-MODE@", forth_acl_mode_fetch);
register_word(vm, "ACL-PINNED?", forth_acl_pinned_query);
register_word(vm, "ACL-TTL@", forth_acl_ttl_fetch);
register_word(vm, "ACL-ALLOW@", forth_acl_allow_fetch);
register_word(vm, "ACL-HEAT@", forth_acl_heat_fetch);
register_word(vm, "ACL-WORD-ID", forth_acl_word_id);
/* Field accessors — write (all no-op if pinned) */
register_word(vm, "ACL-MODE!", forth_acl_mode_store);
register_word(vm, "ACL-TTL!", forth_acl_ttl_store);
register_word(vm, "ACL-ALLOW!", forth_acl_allow_store);
/* Pin ratchet — one-way set */
register_word(vm, "ACL-PIN", forth_acl_pin);
/* Higher-level operations */
register_word(vm, "ACL-INHERIT", forth_acl_inherit);
register_word(vm, "ACL-INIT-PRIMITIVES", forth_acl_init_primitives);
}
v3/src/word_source/arithmetic_words.c
+438
View File
@@ -0,0 +1,438 @@
/*
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.
*/
/* arithmetic_words.c - FORTH-79 Arithmetic Words */
#include "include/arithmetic_words.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
/* FORTH-79 Arithmetic Words:
* + ( n1 n2 -- n3 ) Add n1 and n2
* - ( n1 n2 -- n3 ) Subtract n2 from n1
* * ( n1 n2 -- n3 ) Multiply n1 and n2
* / ( n1 n2 -- n3 ) Divide n1 by n2
* MOD ( n1 n2 -- n3 ) n1 modulo n2
* /MOD ( n1 n2 -- n3 n4 ) n1/n2 remainder and quotient
* STAR-SLASH ( n1 n2 n3 -- n4 ) n1*n2/n3 with intermediate double
* STAR-SLASH-MOD ( n1 n2 n3 -- n4 n5 ) n1*n2/n3 remainder and quotient
* 1+ ( n -- n+1 ) Add 1
* 1- ( n -- n-1 ) Subtract 1
* 2+ ( n -- n+2 ) Add 2
* 2- ( n -- n-2 ) Subtract 2
* 2* ( n -- n*2 ) Multiply by 2 (left shift)
* 2/ ( n -- n/2 ) Divide by 2 (right shift)
* ABS ( n -- |n| ) Absolute value
* NEGATE ( n -- -n ) Two's complement
* MIN ( n1 n2 -- n3 ) Minimum of n1 and n2
* MAX ( n1 n2 -- n3 ) Maximum of n1 and n2
*/
/* Forward declarations */
static void arithmetic_word_star_slash(VM * vm);
static void arithmetic_word_star_slash_mod(VM * vm);
/**
* @brief Implements FORTH word "+" that adds two numbers
*
* Stack effect: ( n1 n2 -- n3 )
* Adds n1 and n2, pushing their sum n3 onto the stack.
*
* @param vm Pointer to the VM structure
*/
void arithmetic_word_plus(VM *vm) {
if (vm->dsp < 1) {
log_message(LOG_ERROR, "+: Stack underflow");
vm->error = 1;
return;
}
cell_t n2 = vm_pop(vm);
cell_t n1 = vm_pop(vm);
cell_t result = n1 + n2;
vm_push(vm, result);
log_message(LOG_DEBUG, "+: %ld + %ld = %ld", n1, n2, result);
}
/**
* @brief Implements FORTH word "-" that subtracts two numbers
*
* Stack effect: ( n1 n2 -- n3 )
* Subtracts n2 from n1, pushing their difference n3 onto the stack.
*
* @param vm Pointer to the VM structure
*/
static void arithmetic_word_minus(VM *vm) {
if (vm->dsp < 1) {
log_message(LOG_ERROR, "-: Stack underflow");
vm->error = 1;
return;
}
cell_t n2 = vm_pop(vm);
cell_t n1 = vm_pop(vm);
cell_t result = n1 - n2;
vm_push(vm, result);
log_message(LOG_DEBUG, "-: %ld - %ld = %ld", n1, n2, result);
}
/**
* @brief Implements FORTH word "*" that multiplies two numbers
*
* Stack effect: ( n1 n2 -- n3 )
* Multiplies n1 by n2, pushing their product n3 onto the stack.
*
* @param vm Pointer to the VM structure
*/
static void arithmetic_word_multiply(VM *vm) {
if (vm->dsp < 1) {
log_message(LOG_ERROR, "*: Stack underflow");
vm->error = 1;
return;
}
cell_t n2 = vm_pop(vm);
cell_t n1 = vm_pop(vm);
cell_t result = n1 * n2;
vm_push(vm, result);
log_message(LOG_DEBUG, "*: %ld * %ld = %ld", n1, n2, result);
}
/* / ( n1 n2 -- n3 ) Divide n1 by n2 */
static void word_divide(VM *vm) {
if (vm->dsp < 1) {
log_message(LOG_ERROR, "/: Stack underflow");
vm->error = 1;
return;
}
cell_t n2 = vm_pop(vm);
cell_t n1 = vm_pop(vm);
if (n2 == 0) {
log_message(LOG_ERROR, "/: Division by zero");
vm->error = 1;
return;
}
cell_t result = n1 / n2;
vm_push(vm, result);
log_message(LOG_DEBUG, "/: %ld / %ld = %ld", n1, n2, result);
}
/* MOD ( n1 n2 -- n3 ) n1 modulo n2 */
static void mixed_math_word_mod(VM *vm) {
if (vm->dsp < 1) {
log_message(LOG_ERROR, "MOD: Stack underflow");
vm->error = 1;
return;
}
cell_t n2 = vm_pop(vm);
cell_t n1 = vm_pop(vm);
if (n2 == 0) {
log_message(LOG_ERROR, "MOD: Division by zero");
vm->error = 1;
return;
}
cell_t result = n1 % n2;
vm_push(vm, result);
log_message(LOG_DEBUG, "MOD: %ld MOD %ld = %ld", n1, n2, result);
}
/* /MOD ( n1 n2 -- n3 n4 ) n1/n2 remainder and quotient */
static void word_divmod(VM *vm) {
if (vm->dsp < 1) {
log_message(LOG_ERROR, "/MOD: Stack underflow");
vm->error = 1;
return;
}
cell_t n2 = vm_pop(vm);
cell_t n1 = vm_pop(vm);
if (n2 == 0) {
log_message(LOG_ERROR, "/MOD: Division by zero");
vm->error = 1;
return;
}
cell_t remainder = n1 % n2;
cell_t quotient = n1 / n2;
vm_push(vm, remainder); /* remainder first */
vm_push(vm, quotient); /* quotient on top */
log_message(LOG_DEBUG, "/MOD: %ld /MOD %ld = %ld remainder %ld", n1, n2, quotient, remainder);
}
/* STAR-SLASH ( n1 n2 n3 -- n4 ) n1*n2/n3 with intermediate double */
static void arithmetic_word_star_slash(VM *vm) {
if (vm->dsp < 2) {
log_message(LOG_ERROR, "*/: Stack underflow");
vm->error = 1;
return;
}
cell_t n3 = vm_pop(vm); /* divisor */
cell_t n2 = vm_pop(vm); /* multiplier */
cell_t n1 = vm_pop(vm); /* multiplicand */
if (n3 == 0) {
log_message(LOG_ERROR, "*/: Division by zero");
vm->error = 1;
return;
}
/* Use 64-bit intermediate to avoid overflow */
int64_t intermediate = n1 * n2;
cell_t result = (intermediate / n3);
vm_push(vm, result);
log_message(LOG_DEBUG, "*/: %ld * %ld / %ld = %ld", n1, n2, n3, result);
}
/* STAR-SLASH-MOD ( n1 n2 n3 -- n4 n5 ) n1*n2/n3 remainder and quotient */
static void arithmetic_word_star_slash_mod(VM *vm) {
if (vm->dsp < 2) {
log_message(LOG_ERROR, "*/MOD: Stack underflow");
vm->error = 1;
return;
}
cell_t n3 = vm_pop(vm); /* divisor */
cell_t n2 = vm_pop(vm); /* multiplier */
cell_t n1 = vm_pop(vm); /* multiplicand */
if (n3 == 0) {
log_message(LOG_ERROR, "*/MOD: Division by zero");
vm->error = 1;
return;
}
/* Use 64-bit intermediate to avoid overflow */
int64_t intermediate = n1 * n2;
cell_t remainder = (intermediate % n3);
cell_t quotient = (intermediate / n3);
vm_push(vm, remainder); /* remainder first */
vm_push(vm, quotient); /* quotient on top */
}
/* 1+ ( n -- n+1 ) Add 1 */
static void arithmetic_word_one_plus(VM *vm) {
if (vm->dsp < 0) {
log_message(LOG_ERROR, "1+: Stack underflow");
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
vm_push(vm, n + 1);
log_message(LOG_DEBUG, "1+: %ld + 1 = %ld", n, (n + 1));
}
/* 1- ( n -- n-1 ) Subtract 1 */
static void arithmetic_word_one_minus(VM *vm) {
if (vm->dsp < 0) {
log_message(LOG_ERROR, "1-: Stack underflow");
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
vm_push(vm, n - 1);
log_message(LOG_DEBUG, "1-: %ld - 1 = %ld", n, (n - 1));
}
/* 2+ ( n -- n+2 ) Add 2 */
static void arithmetic_word_two_plus(VM *vm) {
if (vm->dsp < 0) {
log_message(LOG_ERROR, "2+: Stack underflow");
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
vm_push(vm, n + 2);
log_message(LOG_DEBUG, "2+: %ld + 2 = %ld", n, (n + 2));
}
/* 2- ( n -- n-2 ) Subtract 2 */
static void arithmetic_word_two_minus(VM *vm) {
if (vm->dsp < 0) {
log_message(LOG_ERROR, "2-: Stack underflow");
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
vm_push(vm, n - 2);
log_message(LOG_DEBUG, "2-: %ld - 2 = %ld", n, (n - 2));
}
/* 2* ( n -- n*2 ) Multiply by 2 (left shift) */
static void arithmetic_word_two_multiply(VM *vm) {
if (vm->dsp < 0) {
log_message(LOG_ERROR, "2*: Stack underflow");
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
vm_push(vm, n << 1);
log_message(LOG_DEBUG, "2*: %ld * 2 = %ld", n, (n << 1));
}
/* 2/ ( n -- n/2 ) Divide by 2 (right shift) */
static void arithmetic_word_two_divide(VM *vm) {
if (vm->dsp < 0) {
log_message(LOG_ERROR, "2/: Stack underflow");
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
vm_push(vm, n >> 1);
log_message(LOG_DEBUG, "2/: %ld / 2 = %ld", n, (n >> 1));
}
/* ABS ( n -- |n| ) Absolute value */
static void arithmetic_word_abs(VM *vm) {
if (vm->dsp < 0) {
log_message(LOG_ERROR, "ABS: Stack underflow");
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
cell_t result = (n < 0) ? -n : n;
vm_push(vm, result);
log_message(LOG_DEBUG, "ABS: |%ld| = %ld", n, result);
}
/* NEGATE ( n -- -n ) Two's complement */
static void arithmetic_word_negate(VM *vm) {
if (vm->dsp < 0) {
log_message(LOG_ERROR, "NEGATE: Stack underflow");
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
vm_push(vm, -n);
log_message(LOG_DEBUG, "NEGATE: -%ld = %ld", n, (-n));
}
/* MIN ( n1 n2 -- n3 ) Minimum of n1 and n2 */
static void arithmetic_word_min(VM *vm) {
if (vm->dsp < 1) {
log_message(LOG_ERROR, "MIN: Stack underflow");
vm->error = 1;
return;
}
cell_t n2 = vm_pop(vm);
cell_t n1 = vm_pop(vm);
cell_t result = (n1 < n2) ? n1 : n2;
vm_push(vm, result);
log_message(LOG_DEBUG, "MIN: min(%ld, %ld) = %ld", n1, n2, result);
}
/* MAX ( n1 n2 -- n3 ) Maximum of n1 and n2 */
static void arithmetic_word_max(VM *vm) {
if (vm->dsp < 1) {
log_message(LOG_ERROR, "MAX: Stack underflow");
vm->error = 1;
return;
}
cell_t n2 = vm_pop(vm);
cell_t n1 = vm_pop(vm);
cell_t result = (n1 > n2) ? n1 : n2;
vm_push(vm, result);
log_message(LOG_DEBUG, "MAX: max(%ld, %ld) = %ld", n1, n2, result);
}
/*
* @brief Registers all FORTH-79 arithmetic words with the VM
*
* This function registers all the standard FORTH-79 arithmetic operations
* including basic arithmetic, advanced math operations, increment/decrement
* operations, and comparison functions.
*
* @param vm Pointer to the VM structure where words will be registered
*/
void register_arithmetic_words(VM *vm) {
log_message(LOG_INFO, "Registering FORTH-79 arithmetic words...");
/* Basic arithmetic */
register_word(vm, "+", arithmetic_word_plus);
register_word(vm, "-", arithmetic_word_minus);
register_word(vm, "*", arithmetic_word_multiply);
register_word(vm, "/", word_divide);
register_word(vm, "MOD", mixed_math_word_mod);
register_word(vm, "/MOD", word_divmod);
/* Advanced arithmetic */
register_word(vm, "*/", arithmetic_word_star_slash);
register_word(vm, "*/MOD", arithmetic_word_star_slash_mod);
/* Increment/decrement */
register_word(vm, "1+", arithmetic_word_one_plus);
register_word(vm, "1-", arithmetic_word_one_minus);
register_word(vm, "2+", arithmetic_word_two_plus);
register_word(vm, "2-", arithmetic_word_two_minus);
register_word(vm, "2*", arithmetic_word_two_multiply);
register_word(vm, "2/", arithmetic_word_two_divide);
/* Sign and comparison */
register_word(vm, "ABS", arithmetic_word_abs);
register_word(vm, "NEGATE", arithmetic_word_negate);
register_word(vm, "MIN", arithmetic_word_min);
register_word(vm, "MAX", arithmetic_word_max);
}
v3/src/word_source/block_words.c
+703
View File
@@ -0,0 +1,703 @@
/*
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.
*/
/*
*** StarForth ***
block_words.c - FORTH-79 Block Words (Layer 3: Forth Interface)
Last modified - 10/02/25, 03:55 PM ET
Author: Robert A. James (rajames) - StarshipOS Forth Project.
License: Creative Commons Zero v1.0 Universal
<http://creativecommons.org/publicdomain/zero/1.0/>
*/
#include "include/block_words.h"
#include "../../include/word_registry.h"
#include "../../include/vm.h"
#include "../../include/block_subsystem.h"
#include <string.h>
#include <stdio.h>
#ifdef __STARKERNEL__
#include "starkernel/vm/stadium_blocks.h" /* stadium_block_dispatch() -- FABRIC-2.md §B */
#endif
/* ----------------------------------------------------------------------
* Architecture:
* - Layer 1: blkio (vtable abstraction)
* - Layer 2: block_subsystem (RAM 0-1023, disk 1024+, 4KB packing)
* - Layer 3: block_words (THIS FILE - Forth interface)
*
* All block I/O now goes through block_subsystem.h API.
* Block 0 is RESERVED for volume metadata.
* ---------------------------------------------------------------------- */
static void set_scr(VM *vm, cell_t blk) {
if (!vm) return;
vm_store_cell(vm, vm->scr_addr, (cell_t) blk);
}
/* Optional utility surface (matches your header) */
/*
* @brief Initializes the block system
* @param vm Pointer to the VM instance
*/
void init_block_system(VM *vm) {
(void) vm;
/* Subsystem initialization happens in main.c via blk_subsys_init() */
}
/**
* @brief Gets a buffer for the specified block
* @param vm Pointer to the VM instance
* @param block_num Block number to retrieve
* @return Pointer to block buffer or NULL if invalid
*/
unsigned char *get_block_buffer(VM *vm, int block_num) {
if (!vm) return NULL;
if (block_num == 0) return NULL; /* Block 0 reserved */
uint8_t *buf = blk_get_buffer((uint32_t) block_num, 0); /* read-only */
if (buf) {
set_scr(vm, (cell_t) block_num);
}
return buf;
}
/**
* @brief Gets an empty buffer for the specified block
* @param vm Pointer to the VM instance
* @param block_num Block number to create
* @return Pointer to empty block buffer or NULL if invalid
*/
unsigned char *get_empty_buffer(VM *vm, int block_num) {
if (!vm) return NULL;
if (block_num == 0) return NULL; /* Block 0 reserved */
uint8_t *buf = blk_get_empty_buffer((uint32_t) block_num);
if (buf) {
set_scr(vm, (cell_t) block_num);
}
return buf;
}
/*
* @brief Marks the current block buffer as dirty
* @param vm Pointer to the VM instance
*/
void mark_buffer_dirty(VM *vm) {
if (!vm) return;
cell_t blk = vm_load_cell(vm, vm->scr_addr);
if (blk > 0) {
blk_update((uint32_t) blk);
}
}
/*
* @brief Saves all dirty buffers
* @param vm Pointer to the VM instance
*/
void save_all_buffers(VM *vm) {
(void) vm;
blk_flush(0); /* flush all */
}
/**
* @brief Empties all user block buffers
* @param vm Pointer to the VM instance
*/
void empty_all_buffers(VM *vm) {
if (!vm) return;
/* Zero blocks USER_BLOCKS_START through max available */
uint32_t total = blk_get_total_blocks();
for (uint32_t blk = USER_BLOCKS_START; blk < total; ++blk) {
uint8_t *buf = blk_get_buffer(blk, 1); /* writable */
if (buf) {
memset(buf, 0, BLOCK_SIZE);
}
}
}
/* --- Block I/O window helpers ----------------------------------------- */
/* Discard the whole VM block window if the device chain has changed since
* it was last validated (Milestone 2h). A device hot-detach followed by a
* later re-attach can reuse both the exact same LBN range
* (block_subsystem.c's chain always appends at the current tail) *and* the
* exact same blk_get_buffer() return address (confirmed live: this
* kernel's own first-fit kmalloc, src/starkernel/memory/kmalloc.c, hands
* the just-freed slot straight back to the very next same-size
* calloc()), so neither LBN nor a cached pointer is a reliable
* "still the same device" signal on its own. Any epoch change discards
* every cached slot outright -- no flush attempt, matching
* blk_subsys_detach_device()'s own reasoning: whatever device the stale
* content belonged to may already be gone by the time this runs. Called at
* the top of every function below that reads vm->blk_vm_lbn[]/
* vm->blk_vm_cbuf[] directly, not just blk_vm_find() -- blk_vm_flush_all()
* walks the same arrays without going through blk_vm_find() first. */
void blk_vm_check_epoch(VM *vm) {
uint64_t epoch = blk_subsys_epoch();
if (epoch == vm->blk_vm_epoch) return;
for (int i = 0; i < BLK_VM_SLOTS; i++) {
vm->blk_vm_lbn[i] = 0;
vm->blk_vm_cbuf[i] = NULL;
vm->blk_vm_dirty[i] = 0;
}
vm->blk_vm_epoch = epoch;
}
/* blk_vm_slot_for_addr ( addr -- slot-index|-1 ): does `addr` fall inside
* the block-window range at all? Pure address arithmetic, no VM state --
* the window's base/size are fixed compile-time constants (vm.h), so this
* doesn't need a VM* the way blk_vm_find() does (that also needs the
* per-VM blk_vm_lbn[]/cbuf[] arrays to check what's actually loaded).
* Exposed (Phase 8 v3, 2026-09-23) for MOVE/CMOVE/CMOVE>'s cross-device
* block-copy check -- they need "is this a block-window address" without
* needing to know or care whether anything's actually loaded there. */
int blk_vm_slot_for_addr(vaddr_t addr) {
if (addr < BLK_VM_WINDOW_BASE || addr >= BLK_VM_WINDOW_BASE + BLK_VM_WINDOW_SIZE)
return -1;
return (int) ((addr - BLK_VM_WINDOW_BASE) / BLOCK_SIZE);
}
/* blk_vm_is_cross_device_copy ( addr1 addr2 -- refuse? ): the actual
* Phase 8 v3 (2026-09-23) check MOVE/CMOVE/CMOVE> call before copying.
* True only when BOTH addresses are block-window addresses AND the LBNs
* currently loaded in those two slots resolve to two different physical
* devices -- the exact shape of `<src> BLOCK <dst> BUFFER ... MOVE`, a
* same-VM, cross-device raw block copy using only stock words. A copy
* where either (or both) address is ordinary VM memory -- the overwhelming
* common case, e.g. staging PAD text into a block, or reading a block out
* for display -- is never flagged: only both-window, both-different-device
* copies are refused. Callers must still do their own vm_addr_ok() bounds
* checks first; this only adds the device-boundary refusal on top. */
int blk_vm_is_cross_device_copy(VM *vm, vaddr_t addr1, vaddr_t addr2) {
int slot1 = blk_vm_slot_for_addr(addr1);
int slot2 = blk_vm_slot_for_addr(addr2);
if (slot1 < 0 || slot2 < 0) return 0;
blk_vm_check_epoch(vm);
uint32_t lbn1 = vm->blk_vm_lbn[slot1];
uint32_t lbn2 = vm->blk_vm_lbn[slot2];
if (lbn1 == 0 || lbn2 == 0) return 0; /* an empty/unassigned slot has nothing to protect */
const void *dev1 = blk_lbn_device_handle(lbn1);
const void *dev2 = blk_lbn_device_handle(lbn2);
if (!dev1 || !dev2) return 0; /* can't resolve -- not this check's job to refuse */
return dev1 != dev2;
}
/* Find the slot holding lbn; return slot index or -1 if not loaded. */
static int blk_vm_find(VM *vm, uint32_t lbn) {
blk_vm_check_epoch(vm);
for (int i = 0; i < BLK_VM_SLOTS; i++) {
if (vm->blk_vm_lbn[i] == lbn && vm->blk_vm_cbuf[i] != NULL)
return i;
}
return -1;
}
/* Evict one slot (write back if dirty), return the freed slot index. */
static int blk_vm_evict(VM *vm) {
/* Prefer a clean slot to avoid unnecessary writeback. */
for (int i = 0; i < BLK_VM_SLOTS; i++) {
int s = (vm->blk_vm_next + i) % BLK_VM_SLOTS;
if (vm->blk_vm_cbuf[s] == NULL || !vm->blk_vm_dirty[s]) {
vm->blk_vm_lbn[s] = 0;
vm->blk_vm_cbuf[s] = NULL;
vm->blk_vm_dirty[s] = 0;
vm->blk_vm_next = (s + 1) % BLK_VM_SLOTS;
return s;
}
}
/* All slots dirty: evict round-robin, sync back to C buffer first.
* Re-resolve the buffer pointer by LBN rather than trusting the
* stored one -- the block-subsystem's own devblock cache may have
* shifted (struct-copy eviction) since this slot was populated,
* which silently invalidates any raw pointer captured earlier. */
int s = vm->blk_vm_next;
vm->blk_vm_next = (vm->blk_vm_next + 1) % BLK_VM_SLOTS;
vaddr_t base = BLK_VM_WINDOW_BASE + (vaddr_t)s * BLOCK_SIZE;
uint8_t* fresh = blk_get_buffer(vm->blk_vm_lbn[s], 1);
if (fresh)
{
memcpy(fresh, vm->memory + base, BLOCK_SIZE);
blk_update(vm->blk_vm_lbn[s]);
}
vm->blk_vm_lbn[s] = 0;
vm->blk_vm_cbuf[s] = NULL;
vm->blk_vm_dirty[s] = 0;
return s;
}
/* Load lbn into a window slot (reads C buffer), return VM offset or 0 on err. */
static vaddr_t blk_vm_load(VM *vm, uint32_t lbn, int writable) {
int s = blk_vm_find(vm, lbn);
if (s < 0) {
s = -1;
for (int i = 0; i < BLK_VM_SLOTS; i++) {
if (vm->blk_vm_cbuf[i] == NULL) { s = i; break; }
}
if (s < 0) s = blk_vm_evict(vm);
uint8_t *cbuf = blk_get_buffer(lbn, writable);
if (!cbuf) return 0;
vaddr_t base = BLK_VM_WINDOW_BASE + (vaddr_t)s * BLOCK_SIZE;
memcpy(vm->memory + base, cbuf, BLOCK_SIZE);
vm->blk_vm_lbn[s] = lbn;
vm->blk_vm_cbuf[s] = cbuf;
vm->blk_vm_dirty[s] = 0;
}
return BLK_VM_WINDOW_BASE + (vaddr_t)s * BLOCK_SIZE;
}
/* Assign lbn to a slot WITHOUT reading block content (BUFFER semantics).
* Returns VM offset or 0 on error. Slot is zeroed and marked dirty. */
static vaddr_t blk_vm_assign(VM *vm, uint32_t lbn) {
int s = blk_vm_find(vm, lbn);
if (s < 0) {
s = -1;
for (int i = 0; i < BLK_VM_SLOTS; i++) {
if (vm->blk_vm_cbuf[i] == NULL) { s = i; break; }
}
if (s < 0) s = blk_vm_evict(vm);
uint8_t *cbuf = blk_get_empty_buffer(lbn);
if (!cbuf) return 0;
vaddr_t base = BLK_VM_WINDOW_BASE + (vaddr_t)s * BLOCK_SIZE;
memset(vm->memory + base, 0, BLOCK_SIZE);
vm->blk_vm_lbn[s] = lbn;
vm->blk_vm_cbuf[s] = cbuf;
}
vm->blk_vm_dirty[s] = 1;
return BLK_VM_WINDOW_BASE + (vaddr_t)s * BLOCK_SIZE;
}
/* Sync all dirty slots to their C buffers and flush the subsystem.
* Re-resolve each buffer pointer by LBN rather than trusting the stored
* one -- see blk_vm_evict for why a stored pointer can go stale. Checks
* the epoch first (Milestone 2h, see blk_vm_check_epoch()) since this
* function walks vm->blk_vm_lbn[]/vm->blk_vm_cbuf[] directly rather than
* through blk_vm_find() -- a stale-epoch dirty slot must be discarded, not
* flushed onto whatever device now owns that LBN.
*
* Non-static: this is the entire implementation behind SAVE-BUFFERS
* (block_word_save_buffers() below is a one-line wrapper) -- exposed
* (declared in block_words.h) so kernel-side code can reuse the exact
* same flush path outside the word-dispatch mechanism, e.g. sk_repl_idle()
* (see FABRIC-0.md/FABRIC-1.md Section V item 6). Cheap to call when
* nothing is dirty: every check below is a small fixed-size scan
* (BLK_VM_SLOTS here, DISK_CACHE_SLOTS per device inside blk_flush()),
* no I/O happens unless something actually needs writing. */
void blk_vm_flush_all(VM *vm) {
blk_vm_check_epoch(vm);
for (int i = 0; i < BLK_VM_SLOTS; i++) {
if (vm->blk_vm_cbuf[i] != NULL && vm->blk_vm_dirty[i]) {
vaddr_t base = BLK_VM_WINDOW_BASE + (vaddr_t)i * BLOCK_SIZE;
uint8_t* fresh = blk_get_buffer(vm->blk_vm_lbn[i], 1);
if (fresh)
{
memcpy(fresh, vm->memory + base, BLOCK_SIZE);
blk_update(vm->blk_vm_lbn[i]);
}
vm->blk_vm_dirty[i] = 0;
}
}
blk_flush(0);
}
/* --- Words ------------------------------------------------------------ */
/* BLOCK ( u -- addr ) : VM address of block u content (no dirty mark) */
void block_word_block(VM *vm) {
if (vm->dsp < 0) { vm->error = 1; return; }
cell_t blk = vm_pop(vm);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) { vm->error = 1; return; }
#ifdef __STARKERNEL__
stadium_block_dispatch(vm->stadium_vm_id, (uint32_t) blk, vm->heartbeat.tick_count);
#endif
vaddr_t vaddr = blk_vm_load(vm, (uint32_t) blk, 0);
if (!vaddr) { vm->error = 1; return; }
set_scr(vm, blk);
vm_push(vm, CELL(vaddr));
}
/* BUFFER ( u -- addr ) : VM address of block u; content unread, mark dirty */
void block_word_buffer(VM *vm) {
if (vm->dsp < 0) { vm->error = 1; return; }
cell_t blk = vm_pop(vm);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) { vm->error = 1; return; }
#ifdef __STARKERNEL__
stadium_block_dispatch(vm->stadium_vm_id, (uint32_t) blk, vm->heartbeat.tick_count);
#endif
vaddr_t vaddr = blk_vm_assign(vm, (uint32_t) blk);
if (!vaddr) { vm->error = 1; return; }
set_scr(vm, blk);
vm_push(vm, CELL(vaddr));
}
/* UPDATE ( -- ) : sync current SCR slot to C layer and mark dirty.
* Re-resolve the buffer pointer by LBN rather than trusting the stored
* one -- see blk_vm_evict for why a stored pointer can go stale. */
void block_word_update(VM *vm) {
cell_t blk = vm_load_cell(vm, vm->scr_addr);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) { vm->error = 1; return; }
#ifdef __STARKERNEL__
stadium_block_dispatch(vm->stadium_vm_id, (uint32_t) blk, vm->heartbeat.tick_count);
#endif
int s = blk_vm_find(vm, (uint32_t) blk);
if (s < 0) { vm->error = 1; return; }
vaddr_t base = BLK_VM_WINDOW_BASE + (vaddr_t)s * BLOCK_SIZE;
uint8_t* fresh = blk_get_buffer((uint32_t)blk, 1);
if (!fresh)
{
vm->error = 1;
return;
}
memcpy(fresh, vm->memory + base, BLOCK_SIZE);
vm->blk_vm_cbuf[s] = fresh;
vm->blk_vm_dirty[s] = 1;
blk_update((uint32_t) blk);
}
/* BLK-CONFIRM-FORMAT ( lbn -- ) : commit the low-level disk container
* format for the slot owning lbn. Must be called by the disk's owner
* (e.g. Artemis) only after classifying disk content as safe to touch —
* never on the path that halts for unrecognized content. Until this is
* called, all writes to that disk slot are refused by the block layer. */
void block_word_confirm_format(VM *vm) {
if (vm->dsp < 0) { vm->error = 1; return; }
cell_t blk = vm_pop(vm);
if (blk_subsys_confirm_format((uint32_t) blk) != BLK_OK) { vm->error = 1; return; }
}
/* RELOCATE-BLOCK ( home target -- ) : relocate home's content to target,
* redirecting all future access to home transparently through target
* from now on. See blk_subsys_relocate_block()'s own doc comment
* (block_subsystem.h) for the full contract -- this word performs no
* policy validation of its own (is target actually free? does the
* caller actually own it?), matching this project's "ACL owns policy,
* this is a mechanical primitive" direction. */
void block_word_relocate(VM *vm) {
if (vm->dsp < 1) { vm->error = 1; return; }
cell_t target = vm_pop(vm);
cell_t home = vm_pop(vm);
if (blk_subsys_relocate_block((uint32_t) home, (uint32_t) target) != BLK_OK) {
vm->error = 1;
}
}
/* SAVE-BUFFERS ( -- ) : sync and write all dirty blocks */
void block_word_save_buffers(VM *vm) {
blk_vm_flush_all(vm);
}
/* EMPTY-BUFFERS ( -- ) : invalidate all window slots then zero user blocks */
void block_word_empty_buffers(VM *vm) {
for (int i = 0; i < BLK_VM_SLOTS; i++) {
vm->blk_vm_lbn[i] = 0;
vm->blk_vm_cbuf[i] = NULL;
vm->blk_vm_dirty[i] = 0;
}
empty_all_buffers(vm);
}
/* FLUSH ( -- ) : save and invalidate all buffers */
void block_word_flush(VM *vm) {
blk_vm_flush_all(vm);
}
/* LOAD ( u -- ) : set SCR and (future: interpret block) */
void block_word_load(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t blk = vm_pop(vm);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) {
vm->error = 1;
return;
}
uint8_t *buf = blk_get_buffer((uint32_t) blk, 0);
if (!buf) {
vm->error = 1;
return;
}
set_scr(vm, blk);
/* Interpret the block content as Forth source */
/* Block is 1024 bytes, null-terminate it for interpretation */
char block_text[1025];
memcpy(block_text, buf, 1024);
block_text[1024] = '\0';
/* Interpret the block content */
vm_interpret(vm, block_text);
}
/* LIST ( u -- ) : set SCR and (optionally) print the block */
void block_word_list(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t blk = vm_pop(vm);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) {
vm->error = 1;
return;
}
uint8_t *buf = blk_get_buffer((uint32_t) blk, 0);
if (!buf) {
vm->error = 1;
return;
}
set_scr(vm, blk);
/* Print formatted block output with line numbers */
printf("\nBlock %ld\n", (long) blk);
/* FORTH blocks are typically 16 lines of 64 characters */
for (int line = 0; line < 16; line++) {
printf("%02d: ", line);
for (int col = 0; col < 64; col++) {
int idx = line * 64 + col;
char ch = (char) buf[idx];
/* Print printable characters, show spaces as-is */
if (ch >= 32 && ch < 127) {
putchar(ch);
} else if (ch == 0) {
/* Null bytes shown as spaces for readability */
putchar(' ');
} else {
/* Non-printable shown as '.' */
putchar('.');
}
}
printf("\n");
}
printf("\n");
}
/* THRU ( u1 u2 -- ) : LOAD each block from u1..u2 inclusive */
void block_word_thru(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t u2 = vm_pop(vm);
cell_t u1 = vm_pop(vm);
if (u1 > u2) {
cell_t t = u1;
u1 = u2;
u2 = t;
}
if (u1 == 0 || !blk_is_valid((uint32_t) u1) || !blk_is_valid((uint32_t) u2)) {
vm->error = 1;
return;
}
for (cell_t blk = u1; blk <= u2; ++blk) {
vm_push(vm, blk);
block_word_load(vm);
if (vm->error) return;
if (vm->abort_requested) return;
}
}
/* SCR ( -- addr ) : push VM address of SCR variable */
void block_word_scr(VM *vm) {
vm_push(vm, CELL(vm->scr_addr));
}
/* --> ( -- ) : continue interpretation on next sequential block */
void block_word_next_block(VM *vm) {
cell_t current_scr = vm_load_cell(vm, vm->scr_addr);
cell_t next_blk = current_scr + 1;
if (next_blk == 0 || !blk_is_valid((uint32_t) next_blk)) {
vm->error = 1;
return;
}
/* Get the next block's content */
uint8_t *buf = blk_get_buffer((uint32_t) next_blk, 0);
if (!buf) {
vm->error = 1;
return;
}
/* Update SCR to next block */
set_scr(vm, next_blk);
/* Interpret the next block's content line-by-line (same as LOAD) */
char block_text[1025];
memcpy(block_text, buf, 1024);
block_text[1024] = '\0';
char *p = block_text;
while (!vm->error && !vm->abort_requested && *p != '\0') {
char *nl = (char *)memchr(p, '\n', (size_t)(block_text + 1024 - p));
if (nl) {
*nl = '\0';
if (p != nl)
vm_interpret(vm, p);
p = nl + 1;
} else {
if (*p != '\0')
vm_interpret(vm, p);
break;
}
}
}
/* --- BMAPFMT block-ACL words (FABRIC-2.md §F.4/§H.6/§H.12 step 15) ----
* Raw C-primitive accessors, matching the word-level ACL system's own
* split: policy is composed in FORTH on top of these (a new capsule,
* §H.12 step 16), not here. block_num validated the same way BLOCK/
* BUFFER above already do. */
/* BLK-ACL-ALLOW@ ( block# -- allow ) */
static void block_word_acl_allow_fetch(VM *vm) {
if (vm->dsp < 0) { vm->error = 1; return; }
cell_t blk = vm_pop(vm);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) { vm->error = 1; return; }
uint8_t allow;
if (blk_acl_allow_get((uint32_t) blk, &allow) != BLK_OK) { vm->error = 1; return; }
vm_push(vm, (cell_t) allow);
}
/* BLK-ACL-ALLOW! ( allow block# -- ) */
static void block_word_acl_allow_store(VM *vm) {
if (vm->dsp < 1) { vm->error = 1; return; }
cell_t blk = vm_pop(vm);
cell_t allow = vm_pop(vm);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) { vm->error = 1; return; }
if (blk_acl_allow_set((uint32_t) blk, (uint8_t)(allow ? 1 : 0)) != BLK_OK) {
vm->error = 1;
}
}
/* BLK-ACL-TTL@ ( block# -- ttl ) */
static void block_word_acl_ttl_fetch(VM *vm) {
if (vm->dsp < 0) { vm->error = 1; return; }
cell_t blk = vm_pop(vm);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) { vm->error = 1; return; }
uint32_t ttl;
if (blk_acl_ttl_get((uint32_t) blk, &ttl) != BLK_OK) { vm->error = 1; return; }
vm_push(vm, (cell_t) ttl);
}
/* BLK-ACL-TTL! ( ttl block# -- ) */
static void block_word_acl_ttl_store(VM *vm) {
if (vm->dsp < 1) { vm->error = 1; return; }
cell_t blk = vm_pop(vm);
cell_t ttl = vm_pop(vm);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) { vm->error = 1; return; }
if (blk_acl_ttl_set((uint32_t) blk, (uint32_t) ttl) != BLK_OK) { vm->error = 1; }
}
/* BLK-OWNER@ ( block# -- fp ) : 8-byte owner fingerprint packed into one
* cell (cell_t is 8 bytes, int64_t -- see vm.h) -- raw bit reinterpretation,
* not a numeric value. Read-only from FORTH: only step 15's own list, no
* BLK-OWNER! -- setting ownership happens at a more controlled point
* (MINT/birth), in C, not exposed as a general FORTH write. */
static void block_word_owner_fetch(VM *vm) {
if (vm->dsp < 0) { vm->error = 1; return; }
cell_t blk = vm_pop(vm);
if (blk == 0 || !blk_is_valid((uint32_t) blk)) { vm->error = 1; return; }
uint8_t fp[8];
if (blk_owner_fp_get((uint32_t) blk, fp) != BLK_OK) { vm->error = 1; return; }
cell_t packed;
memcpy(&packed, fp, sizeof(packed));
vm_push(vm, packed);
}
/* BLK-ATTACH ( dev-addr -- ok? ) : registers an already-open blkio_dev_t
* (its raw C pointer, passed as a cell -- the same "embed a pointer as a
* number in generated FORTH text" pattern VM-EXEC/the console relay
* already use) into the block subsystem's unified LBN address space via
* blk_subsys_attach_device(). This is the storage/persistence half of a
* USB drive attach -- Artemis's own domain -- split out from repl.c's
* attach loop so it can run as a message target (capsules/artemis/
* init.4th's HERA-BLK-ATTACH-REQ) instead of a direct C call, per Captain
* Bob's 2026-09-07 messaging-migration decision: Hera keeps polling and
* sig-checking, but no longer performs this step herself. dev-addr is
* trusted as a valid blkio_dev_t* from a live attach in progress -- there
* is no way to validate an arbitrary pointer from FORTH space, matching
* every other raw-pointer word this driver already exposes (e.g.
* dictionary_manipulation_words.c's >LINK/LINK>/CFA). */
static void block_word_blk_attach(VM *vm) {
if (vm->dsp < 0) { vm->error = 1; return; }
cell_t dev_addr = vm_pop(vm);
struct blkio_dev *dev = (struct blkio_dev *)(uintptr_t)dev_addr;
int rc = blk_subsys_attach_device(dev);
vm_push(vm, (rc == BLK_OK) ? 1 : 0);
}
/* --- Registration ----------------------------------------------------- */
/*
* @brief Registers all block-related FORTH words
* @param vm Pointer to the VM instance
*/
void register_block_words(VM *vm) {
register_word(vm, "BLOCK", block_word_block);
register_word(vm, "BUFFER", block_word_buffer);
register_word(vm, "UPDATE", block_word_update);
register_word(vm, "BLK-CONFIRM-FORMAT", block_word_confirm_format);
register_word(vm, "RELOCATE-BLOCK", block_word_relocate);
register_word(vm, "SAVE-BUFFERS", block_word_save_buffers);
register_word(vm, "EMPTY-BUFFERS", block_word_empty_buffers);
register_word(vm, "FLUSH", block_word_flush);
register_word(vm, "LOAD", block_word_load);
register_word(vm, "LIST", block_word_list);
register_word(vm, "THRU", block_word_thru);
register_word(vm, "SCR", block_word_scr);
register_word(vm, "-->", block_word_next_block);
register_word(vm, "BLK-ACL-ALLOW@", block_word_acl_allow_fetch);
register_word(vm, "BLK-ACL-ALLOW!", block_word_acl_allow_store);
register_word(vm, "BLK-ACL-TTL@", block_word_acl_ttl_fetch);
register_word(vm, "BLK-ACL-TTL!", block_word_acl_ttl_store);
register_word(vm, "BLK-OWNER@", block_word_owner_fetch);
register_word(vm, "BLK-ATTACH", block_word_blk_attach);
}
v3/src/word_source/control_words.c
+976
View File
@@ -0,0 +1,976 @@
/*
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/control_words.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
#include "../../include/vm.h"
#include <stddef.h>
#include <stdint.h>
/** @name Internal Runtime Functions
* Forward declarations for internal runtime helpers and control flow primitives
* @{
*/
/** Execute unconditional branch */
static void control_forth_branch(VM * vm);
/** Execute conditional branch based on top of stack */
static void control_forth_0branch(VM * vm);
/** Runtime handler for ?DO loops */
static void control_forth_runtime_qdo(VM * vm);
/** Runtime handler for DO loops */
static void control_forth_runtime_do(VM * vm);
/** Runtime handler for LOOP */
static void control_forth_runtime_loop(VM * vm);
/** Runtime handler for +LOOP */
static void control_forth_runtime_plus_loop(VM * vm);
/** Runtime handler for LEAVE */
static void control_forth_runtime_leave(VM * vm);
/** Get current loop index */
static void control_forth_I(VM * vm);
/** Get outer loop index */
static void control_forth_J(VM * vm);
/** Exit from current definition */
static void control_forth_EXIT(VM * vm);
/** @} */
/**
* @defgroup cf Control Flow Stack
* Compile-time control flow stack for tracking branch targets and loop
* structures. The types (cf_tag_t, cf_item_t, ControlFlowState) and the
* CF_STACK_MAX constant live in include/vm.h and the storage itself lives
* per-VM at vm->cf, so two VMs compiling colon definitions concurrently
* never share nesting state (see include/vm.h's ControlFlowState comment).
* @{
*/
static inline void cf_epoch_sync(VM *vm) {
if (!vm) return;
if (vm->cf.cf_last_mode == -999) {
vm->cf.cf_last_mode = vm->mode;
return;
}
if ((int)vm->mode != vm->cf.cf_last_mode) {
vm->cf.cf_sp = -1;
vm->cf.cf_last_mode = vm->mode;
log_message(LOG_DEBUG, "CF: reset (mode transition)");
}
}
static inline int cf_push_item(VM *vm, cf_tag_t tag, size_t mark) {
if (vm->cf.cf_sp + 1 >= CF_STACK_MAX) {
log_message(LOG_ERROR, "CF: overflow");
return 0;
}
++vm->cf.cf_sp;
vm->cf.cf_stack[vm->cf.cf_sp].tag = tag;
vm->cf.cf_stack[vm->cf.cf_sp].addr = mark;
return 1;
}
static inline int cf_pop_item(VM *vm, cf_item_t *out) {
if (vm->cf.cf_sp < 0) {
log_message(LOG_ERROR, "CF: underflow");
return 0;
}
if (out) {
*out = vm->cf.cf_stack[vm->cf.cf_sp];
}
--vm->cf.cf_sp;
return 1;
}
static inline int cf_peek_item(VM *vm, cf_item_t *out) {
if (vm->cf.cf_sp < 0) return 0;
if (out) {
*out = vm->cf.cf_stack[vm->cf.cf_sp];
}
return 1;
}
/** @} */
/* ===================== Low-level compile helpers ===================== */
static inline size_t emit_cell(VM *vm, cell_t value) {
if (vm->mode != MODE_COMPILE) {
vm_push(vm, value);
return (size_t) -1;
}
vm_align(vm);
cell_t *addr = (cell_t *) vm_allot(vm, sizeof(cell_t));
if (!addr) {
vm->error = 1;
log_message(LOG_ERROR, "emit_cell: out of space");
return (size_t) -1;
}
*addr = value;
return (size_t) ((uint8_t *) addr - vm->memory);
}
/**
* @defgroup runtime Runtime Branch Helpers
* Runtime support for control flow operations
* @details All functions operate on the per-step return IP (top of RS).
* All offsets are in BYTES.
* @{
*/
/**
* Runtime unconditional branch
* @param vm Virtual machine state
*/
static void control_forth_branch(VM *vm) {
if (vm->rsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "BRANCH: RSP underflow");
return;
}
cell_t *ip = (cell_t *) (uintptr_t) vm->return_stack[vm->rsp];
cell_t rel = *ip;
ip = (cell_t *) ((uint8_t *) ip + (intptr_t) rel);
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
ip;
log_message(LOG_DEBUG, "BRANCH: +%ld bytes", (long) rel);
}
/* (0BRANCH) ( f -- ) */
static void control_forth_0branch(VM *vm) {
if (vm->rsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "0BRANCH: RSP underflow");
return;
}
if (vm->dsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "0BRANCH: DSP underflow");
return;
}
cell_t *ip = (cell_t *) (uintptr_t) vm->return_stack[vm->rsp];
cell_t flag = vm_pop(vm);
cell_t rel = *ip;
if (flag == 0) {
ip = (cell_t *) ((uint8_t *) ip + (intptr_t) rel);
log_message(LOG_DEBUG, "0BRANCH: taken +%ld", (long) rel);
} else {
ip = ip + 1;
log_message(LOG_DEBUG, "0BRANCH: not taken");
}
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
ip;
}
/* (?DO) ( limit index -- ) */
static void control_forth_runtime_qdo(VM *vm) {
if (vm->rsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "?DO: RSP underflow");
return;
}
if (vm->dsp < 1) {
vm->error = 1;
log_message(LOG_ERROR, "?DO: DSP underflow");
return;
}
cell_t index = vm_pop(vm);
cell_t limit = vm_pop(vm);
cell_t *ip = (cell_t *) (uintptr_t) vm->return_stack[vm->rsp];
cell_t rel = *ip;
if (index == limit) {
ip = (cell_t *) ((uint8_t *) ip + (intptr_t) rel);
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
ip;
log_message(LOG_DEBUG, "?DO: empty -> +%ld", (long) rel);
return;
}
/* enter loop at body (skip rel) and insert (limit,index) under IP */
ip = ip + 1;
if (vm->rsp + 2 >= STACK_SIZE) {
vm->error = 1;
log_message(LOG_ERROR, "?DO: RSTACK overflow");
return;
}
vm->return_stack[vm->rsp + 2] = (cell_t)(uintptr_t)
ip;
vm->return_stack[vm->rsp + 1] = index;
vm->return_stack[vm->rsp + 0] = limit;
vm->rsp += 2;
log_message(LOG_DEBUG, "?DO: enter (index=%ld limit=%ld)", (long) index, (long) limit);
}
/* (DO) ( limit index -- ) */
static void control_forth_runtime_do(VM *vm) {
if (vm->rsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "DO: RSP underflow");
return;
}
if (vm->dsp < 1) {
vm->error = 1;
log_message(LOG_ERROR, "DO: DSP underflow");
return;
}
cell_t index = vm_pop(vm);
cell_t limit = vm_pop(vm);
if (vm->rsp + 2 >= STACK_SIZE) {
vm->error = 1;
log_message(LOG_ERROR, "DO: RSTACK overflow");
return;
}
cell_t ip_cell = vm->return_stack[vm->rsp];
vm->return_stack[vm->rsp + 2] = ip_cell; /* move IP up */
vm->return_stack[vm->rsp + 1] = index;
vm->return_stack[vm->rsp + 0] = limit;
vm->rsp += 2;
log_message(LOG_DEBUG, "DO: enter (index=%ld limit=%ld)", (long) index, (long) limit);
}
/* (LOOP) */
static void control_forth_runtime_loop(VM *vm) {
if (vm->rsp < 2) {
vm->error = 1;
log_message(LOG_ERROR, "LOOP: missing loop frame");
return;
}
cell_t *ip = (cell_t *) (uintptr_t) vm->return_stack[vm->rsp];
cell_t *idxp = &vm->return_stack[vm->rsp - 1];
cell_t *limp = &vm->return_stack[vm->rsp - 2];
(*idxp) += 1;
cell_t back = *ip; /* BYTES */
if (*idxp < *limp) {
ip = (cell_t *) ((uint8_t *) ip + (intptr_t) back);
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
ip;
log_message(LOG_DEBUG, "LOOP: continue (index=%ld)", (long) *idxp);
} else {
vm->rsp -= 2; /* drop INDEX,LIMIT */
ip = ip + 1; /* skip back-offset */
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
ip;
log_message(LOG_DEBUG, "LOOP: exit");
}
}
/* (+LOOP) ( n -- ) */
static void control_forth_runtime_plus_loop(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "+LOOP: DSP underflow");
return;
}
if (vm->rsp < 2) {
vm->error = 1;
log_message(LOG_ERROR, "+LOOP: missing loop frame");
return;
}
cell_t n = vm_pop(vm);
cell_t *ip = (cell_t *) (uintptr_t) vm->return_stack[vm->rsp];
cell_t *idxp = &vm->return_stack[vm->rsp - 1];
cell_t *limp = &vm->return_stack[vm->rsp - 2];
cell_t newv = (*idxp) + n;
*idxp = newv;
cell_t back = *ip; /* BYTES */
int cont = (n >= 0) ? (newv < *limp) : (newv >= *limp);
if (cont) {
ip = (cell_t *) ((uint8_t *) ip + (intptr_t) back);
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
ip;
log_message(LOG_DEBUG, "+LOOP: continue (index=%ld)", (long) newv);
} else {
vm->rsp -= 2;
ip = ip + 1;
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
ip;
log_message(LOG_DEBUG, "+LOOP: exit");
}
}
/* (LEAVE) ( -- ) — force loop to exit at next LOOP/+LOOP */
static void control_forth_runtime_leave(VM *vm) {
if (vm->rsp < 2) {
vm->error = 1;
log_message(LOG_ERROR, "LEAVE: outside loop");
return;
}
vm->return_stack[vm->rsp - 1] = vm->return_stack[vm->rsp - 2]; /* index = limit */
log_message(LOG_DEBUG, "LEAVE: flagged exit");
}
/* UNLOOP ( -- ) — discard loop parameters from return stack */
static void control_forth_UNLOOP(VM *vm) {
if (vm->rsp < 2) {
vm->error = 1;
log_message(LOG_ERROR, "UNLOOP: outside loop (return stack underflow)");
return;
}
/* Return stack layout: ..., limit (rsp-2), index (rsp-1), ip (rsp) */
/* Move IP from rsp down to rsp-2, then decrement rsp by 2 */
vm->return_stack[vm->rsp - 2] = vm->return_stack[vm->rsp];
vm->rsp -= 2;
log_message(LOG_DEBUG, "UNLOOP: removed loop parameters (limit, index)");
}
/* I ( -- i ) */
static void control_forth_I(VM *vm) {
if (vm->rsp < 2) {
vm->error = 1;
log_message(LOG_ERROR, "I: outside DO loop");
return;
}
vm_push(vm, vm->return_stack[vm->rsp - 1]); /* INDEX */
}
/* J ( -- j ) — next-outer loop index */
static void control_forth_J(VM *vm) {
if (vm->rsp < 4) {
vm->error = 1;
log_message(LOG_ERROR, "J: needs nested DO loops");
return;
}
vm_push(vm, vm->return_stack[vm->rsp - 3]); /* outer INDEX */
}
/* EXIT — one-shot return from current colon definition (guarded) */
static void control_forth_EXIT(VM *vm) {
if (vm->rsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "EXIT: interpret-time use is invalid");
return;
}
vm->exit_colon = 1;
log_message(LOG_DEBUG, "EXIT: return from colon");
}
/* ===================== Compile-time words ===================== */
static void control_forth_if(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "IF: compile-only");
return;
}
vm_compile_call(vm, control_forth_0branch);
size_t lit = emit_cell(vm, 0);
if (!cf_push_item(vm, CF_IF, lit)) {
vm->error = 1;
return;
}
log_message(LOG_DEBUG, "IF: placeholder @ %zu", lit);
}
static void control_forth_else(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "ELSE: compile-only");
return;
}
cf_item_t it;
if (!cf_peek_item(vm, &it) || it.tag != CF_IF) {
vm->error = 1;
log_message(LOG_ERROR, "ELSE: missing IF");
return;
}
(void) cf_pop_item(vm, &it);
vm_compile_call(vm, control_forth_branch);
size_t new_lit = emit_cell(vm, 0);
cell_t off = (cell_t)((size_t) vm->here - it.addr);
*(cell_t *) (vm->memory + it.addr) = off;
if (!cf_push_item(vm, CF_ELSE, new_lit)) {
vm->error = 1;
return;
}
log_message(LOG_DEBUG, "ELSE: patched IF @ %zu -> +%ld; new lit @ %zu", it.addr, (long) off, new_lit);
}
static void control_forth_then(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "THEN: compile-only");
return;
}
cf_item_t it;
if (!cf_pop_item(vm, &it) || (it.tag != CF_IF && it.tag != CF_ELSE)) {
vm->error = 1;
log_message(LOG_ERROR, "THEN: unmatched");
return;
}
cell_t off = (cell_t)((size_t) vm->here - it.addr);
*(cell_t *) (vm->memory + it.addr) = off;
log_message(LOG_DEBUG, "THEN: patched lit @ %zu -> +%ld", it.addr, (long) off);
}
static void control_forth_begin(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "BEGIN: compile-only");
return;
}
if (!cf_push_item(vm, CF_BEGIN, vm->here)) {
vm->error = 1;
return;
}
log_message(LOG_DEBUG, "BEGIN: mark @ %zu", vm->here);
}
static void control_forth_until(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "UNTIL: compile-only");
return;
}
cf_item_t begin;
if (!cf_pop_item(vm, &begin) || begin.tag != CF_BEGIN) {
vm->error = 1;
log_message(LOG_ERROR, "UNTIL: missing BEGIN");
return;
}
vm_compile_call(vm, control_forth_0branch);
cell_t back = (cell_t)((cell_t) begin.addr - (cell_t) vm->here);
(void) emit_cell(vm, back);
log_message(LOG_DEBUG, "UNTIL: back -> %zu (%ld bytes)", begin.addr, (long) back);
}
static void control_forth_again(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "AGAIN: compile-only");
return;
}
cf_item_t begin;
if (!cf_pop_item(vm, &begin) || begin.tag != CF_BEGIN) {
vm->error = 1;
log_message(LOG_ERROR, "AGAIN: missing BEGIN");
return;
}
vm_compile_call(vm, control_forth_branch);
cell_t back = (cell_t)((cell_t) begin.addr - (cell_t) vm->here);
(void) emit_cell(vm, back);
log_message(LOG_DEBUG, "AGAIN: back -> %zu (%ld bytes)", begin.addr, (long) back);
}
static void control_forth_while(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "WHILE: compile-only");
return;
}
cf_item_t b;
if (!cf_peek_item(vm, &b) || b.tag != CF_BEGIN) {
vm->error = 1;
log_message(LOG_ERROR, "WHILE: needs BEGIN");
return;
}
vm_compile_call(vm, control_forth_0branch);
size_t lit = emit_cell(vm, 0);
if (!cf_push_item(vm, CF_WHILE, lit)) {
vm->error = 1;
return;
}
log_message(LOG_DEBUG, "WHILE: placeholder @ %zu", lit);
}
static void control_forth_repeat(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "REPEAT: compile-only");
return;
}
cf_item_t w, b;
if (!cf_pop_item(vm, &w) || w.tag != CF_WHILE) {
vm->error = 1;
log_message(LOG_ERROR, "REPEAT: missing WHILE");
return;
}
if (!cf_pop_item(vm, &b) || b.tag != CF_BEGIN) {
vm->error = 1;
log_message(LOG_ERROR, "REPEAT: missing BEGIN");
return;
}
vm_compile_call(vm, control_forth_branch);
cell_t back = (cell_t)((cell_t) b.addr - (cell_t) vm->here);
(void) emit_cell(vm, back);
cell_t fwd = (cell_t)((size_t) vm->here - w.addr);
*(cell_t *) (vm->memory + w.addr) = fwd;
log_message(LOG_DEBUG, "REPEAT: WHILE @ %zu -> +%ld; back=%ld to %zu", w.addr, (long) fwd, (long) back, b.addr);
}
/* ?DO ( limit index -- ) compile */
static void control_forth_qdo(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "?DO: compile-only");
return;
}
vm_compile_call(vm, control_forth_runtime_qdo);
size_t fwd_lit = emit_cell(vm, 0);
if (!cf_push_item(vm, CF_DO, vm->here)) {
vm->error = 1;
return;
} /* back target for LOOP */
if (!cf_push_item(vm, CF_WHILE, fwd_lit)) {
vm->error = 1;
return;
} /* forward to loop-end */
vm->cf.leave_mark_stack[++vm->cf.leave_mark_sp] = vm->cf.leave_sp;
log_message(LOG_DEBUG, "?DO: fwd lit @ %zu; back mark=%d", fwd_lit, vm->cf.leave_mark_stack[vm->cf.leave_mark_sp]);
}
/* DO ( limit index -- ) compile */
static void control_forth_do(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "DO: compile-only");
return;
}
vm_compile_call(vm, control_forth_runtime_do);
if (!cf_push_item(vm, CF_DO, vm->here)) {
vm->error = 1;
return;
}
vm->cf.leave_mark_stack[++vm->cf.leave_mark_sp] = vm->cf.leave_sp;
log_message(LOG_DEBUG, "DO: mark @ %zu; leave_mark=%d", vm->here, vm->cf.leave_mark_stack[vm->cf.leave_mark_sp]);
}
/* LEAVE — compile runtime LEAVE plus BRANCH <placeholder>, collect patch site */
static void control_forth_leave(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "LEAVE: compile-only");
return;
}
/* verify inside DO */
int seen_do = 0;
for (int i = vm->cf.cf_sp; i >= 0; --i) {
if (vm->cf.cf_stack[i].tag == CF_DO) {
seen_do = 1;
break;
}
}
if (!seen_do || vm->cf.leave_mark_sp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "LEAVE: needs DO");
return;
}
vm_compile_call(vm, control_forth_runtime_leave);
vm_compile_call(vm, control_forth_branch);
size_t lit = emit_cell(vm, 0);
if (vm->cf.leave_sp + 1 >= CF_STACK_MAX) {
vm->error = 1;
log_message(LOG_ERROR, "LEAVE: too many sites");
return;
}
vm->cf.leave_addrs[++vm->cf.leave_sp] = lit;
log_message(LOG_DEBUG, "LEAVE: site lit @ %zu (leave_sp=%d)", lit, vm->cf.leave_sp);
}
/* LOOP — compile runtime LOOP + backoffset; patch ?DO fwd and LEAVE sites */
static void control_forth_loop(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "LOOP: compile-only");
return;
}
/* Optional ?DO forward */
cf_item_t maybe_qdo;
int have_qdo = 0;
cf_item_t top;
if (cf_peek_item(vm, &top) && top.tag == CF_WHILE) {
(void) cf_pop_item(vm, &maybe_qdo);
have_qdo = 1;
}
/* Required DO back mark */
cf_item_t do_mark;
if (!cf_pop_item(vm, &do_mark) || do_mark.tag != CF_DO) {
vm->error = 1;
log_message(LOG_ERROR, "LOOP: missing DO");
return;
}
vm_compile_call(vm, control_forth_runtime_loop);
cell_t back = (cell_t)((cell_t) do_mark.addr - (cell_t) vm->here);
(void) emit_cell(vm, back);
if (have_qdo) {
cell_t fwd = (cell_t)((size_t) vm->here - maybe_qdo.addr);
*(cell_t *) (vm->memory + maybe_qdo.addr) = fwd;
log_message(LOG_DEBUG, "LOOP: patched ?DO @ %zu -> +%ld", maybe_qdo.addr, (long) fwd);
}
if (vm->cf.leave_mark_sp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "LOOP: LEAVE mark underflow");
return;
}
int mark = vm->cf.leave_mark_stack[vm->cf.leave_mark_sp--];
for (int i = vm->cf.leave_sp; i > mark; --i) {
size_t addr = vm->cf.leave_addrs[i];
cell_t fwd = (cell_t)((size_t) vm->here - addr);
*(cell_t *) (vm->memory + addr) = fwd;
log_message(LOG_DEBUG, "LEAVE: patched @ %zu -> +%ld", addr, (long) fwd);
}
vm->cf.leave_sp = mark;
log_message(LOG_DEBUG, "LOOP: back -> %zu (%ld bytes)", do_mark.addr, (long) back);
}
/* +LOOP — same as LOOP but with runtime +LOOP */
static void control_forth_plus_loop(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "+LOOP: compile-only");
return;
}
cf_item_t maybe_qdo;
int have_qdo = 0;
cf_item_t top;
if (cf_peek_item(vm, &top) && top.tag == CF_WHILE) {
(void) cf_pop_item(vm, &maybe_qdo);
have_qdo = 1;
}
cf_item_t do_mark;
if (!cf_pop_item(vm, &do_mark) || do_mark.tag != CF_DO) {
vm->error = 1;
log_message(LOG_ERROR, "+LOOP: missing DO");
return;
}
vm_compile_call(vm, control_forth_runtime_plus_loop);
cell_t back = (cell_t)((cell_t) do_mark.addr - (cell_t) vm->here);
(void) emit_cell(vm, back);
if (have_qdo) {
cell_t fwd = (cell_t)((size_t) vm->here - maybe_qdo.addr);
*(cell_t *) (vm->memory + maybe_qdo.addr) = fwd;
log_message(LOG_DEBUG, "+LOOP: patched ?DO @ %zu -> +%ld", maybe_qdo.addr, (long) fwd);
}
if (vm->cf.leave_mark_sp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "+LOOP: LEAVE mark underflow");
return;
}
int mark = vm->cf.leave_mark_stack[vm->cf.leave_mark_sp--];
for (int i = vm->cf.leave_sp; i > mark; --i) {
size_t addr = vm->cf.leave_addrs[i];
cell_t fwd = (cell_t)((size_t) vm->here - addr);
*(cell_t *) (vm->memory + addr) = fwd;
log_message(LOG_DEBUG, "LEAVE: patched @ %zu -> +%ld", addr, (long) fwd);
}
vm->cf.leave_sp = mark;
log_message(LOG_DEBUG, "+LOOP: back -> %zu (%ld bytes)", do_mark.addr, (long) back);
}
/* ===================== CASE/OF/ENDOF/ENDCASE ===================== */
/* Standard FORTH CASE statement:
* n CASE
* val1 OF code1 ENDOF
* val2 OF code2 ENDOF
* default-code
* ENDCASE
*
* Compile-time behavior:
* - CASE: Push CF_CASE marker, record endof_sp for ENDCASE patching
* - OF: Compile OVER = 0BRANCH <endof> DROP, push CF_OF with branch addr
* - ENDOF: Patch OF's forward branch, compile BRANCH <endcase>, save for ENDCASE
* - ENDCASE: Compile DROP, patch all ENDOF branches to here
*/
/* CASE ( n -- n ) compile-time: mark start of case statement */
static void control_forth_case(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "CASE: compile-only");
return;
}
if (!cf_push_item(vm, CF_CASE, 0)) {
vm->error = 1;
return;
}
/* Record current endof_sp so ENDCASE knows which branches to patch */
if (vm->cf.endof_mark_sp + 1 >= CF_STACK_MAX) {
vm->error = 1;
log_message(LOG_ERROR, "CASE: nesting overflow");
return;
}
vm->cf.endof_mark_stack[++vm->cf.endof_mark_sp] = vm->cf.endof_sp;
log_message(LOG_DEBUG, "CASE: mark (endof_mark=%d)", vm->cf.endof_mark_stack[vm->cf.endof_mark_sp]);
}
/* OF ( n1 n2 -- | n1 ) compile-time: compare and branch */
static void control_forth_of(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "OF: compile-only");
return;
}
/* Verify inside CASE */
int seen_case = 0;
for (int i = vm->cf.cf_sp; i >= 0; --i) {
if (vm->cf.cf_stack[i].tag == CF_CASE) {
seen_case = 1;
break;
}
}
if (!seen_case) {
vm->error = 1;
log_message(LOG_ERROR, "OF: needs CASE");
return;
}
/* Compile: OVER = 0BRANCH <endof> DROP */
/* We need to compile calls to OVER and = */
DictEntry *over_entry = vm_find_word(vm, "OVER", 4);
DictEntry *eq_entry = vm_find_word(vm, "=", 1);
DictEntry *drop_entry = vm_find_word(vm, "DROP", 4);
if (!over_entry || !eq_entry || !drop_entry) {
vm->error = 1;
log_message(LOG_ERROR, "OF: missing OVER, =, or DROP");
return;
}
vm_compile_call(vm, over_entry->func);
vm_compile_call(vm, eq_entry->func);
vm_compile_call(vm, control_forth_0branch);
size_t of_branch = emit_cell(vm, 0); /* Placeholder for ENDOF */
vm_compile_call(vm, drop_entry->func);
if (!cf_push_item(vm, CF_OF, of_branch)) {
vm->error = 1;
return;
}
log_message(LOG_DEBUG, "OF: branch placeholder @ %zu", of_branch);
}
/* ENDOF ( -- ) compile-time: end OF clause, jump to ENDCASE */
static void control_forth_endof(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "ENDOF: compile-only");
return;
}
/* Pop CF_OF and patch its forward branch */
cf_item_t of_item;
if (!cf_pop_item(vm, &of_item) || of_item.tag != CF_OF) {
vm->error = 1;
log_message(LOG_ERROR, "ENDOF: missing OF");
return;
}
/* Compile BRANCH to ENDCASE (placeholder) */
vm_compile_call(vm, control_forth_branch);
size_t endcase_branch = emit_cell(vm, 0);
/* Patch OF's 0BRANCH to jump here (after the BRANCH) */
cell_t off = (cell_t)((size_t) vm->here - of_item.addr);
*(cell_t *) (vm->memory + of_item.addr) = off;
/* Save ENDOF's branch for ENDCASE patching */
if (vm->cf.endof_sp + 1 >= CF_STACK_MAX) {
vm->error = 1;
log_message(LOG_ERROR, "ENDOF: too many clauses");
return;
}
vm->cf.endof_addrs[++vm->cf.endof_sp] = endcase_branch;
log_message(LOG_DEBUG, "ENDOF: patched OF @ %zu -> +%ld; endcase branch @ %zu",
of_item.addr, (long) off, endcase_branch);
}
/* ENDCASE ( n -- ) compile-time: end case, drop selector, patch all ENDOFs */
static void control_forth_endcase(VM *vm) {
cf_epoch_sync(vm);
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "ENDCASE: compile-only");
return;
}
/* Pop CF_CASE marker */
cf_item_t case_item;
if (!cf_pop_item(vm, &case_item) || case_item.tag != CF_CASE) {
vm->error = 1;
log_message(LOG_ERROR, "ENDCASE: missing CASE");
return;
}
/* Compile DROP to discard the selector */
DictEntry *drop_entry = vm_find_word(vm, "DROP", 4);
if (!drop_entry) {
vm->error = 1;
log_message(LOG_ERROR, "ENDCASE: missing DROP");
return;
}
vm_compile_call(vm, drop_entry->func);
/* Patch all ENDOF branches to here */
if (vm->cf.endof_mark_sp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "ENDCASE: mark underflow");
return;
}
int mark = vm->cf.endof_mark_stack[vm->cf.endof_mark_sp--];
for (int i = vm->cf.endof_sp; i > mark; --i) {
size_t addr = vm->cf.endof_addrs[i];
cell_t fwd = (cell_t)((size_t) vm->here - addr);
*(cell_t *) (vm->memory + addr) = fwd;
log_message(LOG_DEBUG, "ENDCASE: patched ENDOF @ %zu -> +%ld", addr, (long) fwd);
}
vm->cf.endof_sp = mark;
log_message(LOG_DEBUG, "ENDCASE: complete");
}
/* ===================== Registration ===================== */
void register_control_words(VM *vm) {
if (!vm) return;
/* Internal branches & runtimes */
register_word(vm, "(BRANCH)", control_forth_branch);
register_word(vm, "(0BRANCH)", control_forth_0branch);
register_word(vm, "(?DO)", control_forth_runtime_qdo);
register_word(vm, "(DO)", control_forth_runtime_do);
register_word(vm, "(LOOP)", control_forth_runtime_loop);
register_word(vm, "(+LOOP)", control_forth_runtime_plus_loop);
register_word(vm, "(LEAVE)", control_forth_runtime_leave);
/* IF/ELSE/THEN */
register_word(vm, "IF", control_forth_if);
vm_make_immediate(vm);
register_word(vm, "ELSE", control_forth_else);
vm_make_immediate(vm);
register_word(vm, "THEN", control_forth_then);
vm_make_immediate(vm);
/* BEGIN/WHILE/REPEAT/AGAIN/UNTIL */
register_word(vm, "BEGIN", control_forth_begin);
vm_make_immediate(vm);
register_word(vm, "WHILE", control_forth_while);
vm_make_immediate(vm);
register_word(vm, "REPEAT", control_forth_repeat);
vm_make_immediate(vm);
register_word(vm, "AGAIN", control_forth_again);
vm_make_immediate(vm);
register_word(vm, "UNTIL", control_forth_until);
vm_make_immediate(vm);
/* DO/?DO/LOOP/+LOOP/LEAVE */
register_word(vm, "?DO", control_forth_qdo);
vm_make_immediate(vm);
register_word(vm, "DO", control_forth_do);
vm_make_immediate(vm);
register_word(vm, "LOOP", control_forth_loop);
vm_make_immediate(vm);
register_word(vm, "+LOOP", control_forth_plus_loop);
vm_make_immediate(vm);
register_word(vm, "LEAVE", control_forth_leave);
vm_make_immediate(vm);
/* Loop indices, UNLOOP & EXIT */
register_word(vm, "I", control_forth_I);
register_word(vm, "J", control_forth_J);
register_word(vm, "UNLOOP", control_forth_UNLOOP);
register_word(vm, "EXIT", control_forth_EXIT);
/* CASE/OF/ENDOF/ENDCASE */
register_word(vm, "CASE", control_forth_case);
vm_make_immediate(vm);
register_word(vm, "OF", control_forth_of);
vm_make_immediate(vm);
register_word(vm, "ENDOF", control_forth_endof);
vm_make_immediate(vm);
register_word(vm, "ENDCASE", control_forth_endcase);
vm_make_immediate(vm);
}
v3/src/word_source/defer_words.c
+208
View File
@@ -0,0 +1,208 @@
/*
StarForth — Steady-State Virtual Machine Runtime
Copyright (c) 2023–2025 Robert A. James
All rights reserved.
Licensed under the StarForth License, Version 1.0.
*/
/*
* DEFER / IS / DEFER@ primitives — late-binding deferred words.
*
* DEFER name ( -- ) Create a deferred word, data field = 0 (unset).
* IS name ( xt -- ) Store xt into the data field of a DEFER word.
* DEFER@ name ( -- xt ) Fetch the current action xt of a DEFER word.
*
* When a deferred word executes, defer_runtime reads its data field
* (a raw DictEntry*) and calls that entry's func directly. This is
* essential because the inner interpreter stores DictEntry* pointers
* in compiled bodies at compile time — redefining a colon word after
* compilation does not update callers. DEFER/IS gives late binding
* without any name-lookup overhead at execution time.
*
* IS enforces that the named word was created by DEFER (func ==
* defer_runtime). Attempting IS on any other word sets vm->error.
*/
#include "include/defer_words.h"
#include "../../include/vm.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
#include "../../include/dictionary_management.h"
#include <stdint.h>
/* ── defer_runtime ─────────────────────────────────────────────────────
* The func stored in every DEFER-created word.
* Data field = 0 means unset → error. Non-zero = DictEntry* to call.
*/
static void defer_runtime(VM *vm)
{
if (!vm || !vm->current_executing_entry) { if (vm) vm->error = 1; return; }
DictEntry *self = vm->current_executing_entry;
cell_t *df = vm_dictionary_get_data_field(self);
if (!df || *df == 0)
{
log_message(LOG_ERROR, "DEFER runtime: no target set for '%.*s'",
(int)self->name_len, self->name);
vm->error = 1;
return;
}
DictEntry *target = (DictEntry *)(uintptr_t)(*df);
if (!target || !target->func)
{
log_message(LOG_ERROR, "DEFER runtime: invalid target for '%.*s'",
(int)self->name_len, self->name);
vm->error = 1;
return;
}
vm->current_executing_entry = target;
target->func(vm);
}
/* ── DEFER ─────────────────────────────────────────────────────────────
* DEFER name ( -- )
* Creates a new dictionary entry with defer_runtime as its func.
* Data field initialised to 0 (unset). Calling the word before IS
* has been used will set vm->error.
*/
static void word_defer(VM *vm)
{
char name[WORD_NAME_MAX + 1];
int len = vm_parse_word(vm, name, sizeof(name));
if (len <= 0)
{
log_message(LOG_ERROR, "DEFER: missing name");
vm->error = 1;
return;
}
DictEntry *de = vm_create_word(vm, name, (size_t)len, defer_runtime);
if (!de)
{
log_message(LOG_ERROR, "DEFER: vm_create_word failed for '%.*s'", len, name);
vm->error = 1;
return;
}
cell_t *df = vm_dictionary_get_data_field(de);
if (!df)
{
log_message(LOG_ERROR, "DEFER: no data field for '%.*s'", len, name);
vm->error = 1;
return;
}
*df = 0; /* unset — defer_runtime will error if called before IS */
log_message(LOG_DEBUG, "DEFER: created '%.*s' (unset)", len, name);
}
/* ── IS ────────────────────────────────────────────────────────────────
* IS name ( xt -- )
* Pops an execution token (DictEntry*) from the stack, parses the next
* word from input, and stores the xt into that word's data field.
* The named word MUST have been created by DEFER; any other word causes
* an error. This prevents corrupting non-DEFER words' memory.
*/
static void word_is(VM *vm)
{
if (vm->dsp < 0)
{
log_message(LOG_ERROR, "IS: stack underflow");
vm->error = 1;
return;
}
cell_t xt = vm_pop(vm);
char name[WORD_NAME_MAX + 1];
int len = vm_parse_word(vm, name, sizeof(name));
if (len <= 0)
{
log_message(LOG_ERROR, "IS: missing name");
vm->error = 1;
return;
}
DictEntry *de = vm_find_word(vm, name, (size_t)len);
if (!de)
{
log_message(LOG_ERROR, "IS: word '%.*s' not found", len, name);
vm->error = 1;
return;
}
if (de->func != defer_runtime)
{
log_message(LOG_ERROR, "IS: '%.*s' was not created by DEFER", len, name);
vm->error = 1;
return;
}
cell_t *df = vm_dictionary_get_data_field(de);
if (!df)
{
log_message(LOG_ERROR, "IS: no data field for '%.*s'", len, name);
vm->error = 1;
return;
}
*df = xt;
log_message(LOG_DEBUG, "IS: stored xt into '%.*s'", len, name);
}
/* ── DEFER@ ────────────────────────────────────────────────────────────
* DEFER@ name ( -- xt )
* Parses the next word from input and pushes its current action xt.
* The named word must have been created by DEFER.
*/
static void word_defer_fetch(VM *vm)
{
char name[WORD_NAME_MAX + 1];
int len = vm_parse_word(vm, name, sizeof(name));
if (len <= 0)
{
log_message(LOG_ERROR, "DEFER@: missing name");
vm->error = 1;
return;
}
DictEntry *de = vm_find_word(vm, name, (size_t)len);
if (!de)
{
log_message(LOG_ERROR, "DEFER@: word '%.*s' not found", len, name);
vm->error = 1;
return;
}
if (de->func != defer_runtime)
{
log_message(LOG_ERROR, "DEFER@: '%.*s' was not created by DEFER", len, name);
vm->error = 1;
return;
}
cell_t *df = vm_dictionary_get_data_field(de);
if (!df)
{
log_message(LOG_ERROR, "DEFER@: no data field for '%.*s'", len, name);
vm->error = 1;
return;
}
vm_push(vm, *df);
log_message(LOG_DEBUG, "DEFER@: fetched xt from '%.*s'", len, name);
}
/* ── Registration ──────────────────────────────────────────────────────*/
void register_defer_words(VM *vm)
{
register_word(vm, "DEFER", word_defer);
register_word(vm, "IS", word_is);
register_word(vm, "DEFER@", word_defer_fetch);
}
v3/src/word_source/defining_words.c
+793
View File
@@ -0,0 +1,793 @@
/*
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/defining_words.h"
#include "../../include/vm.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
#include "../../include/profiler.h"
#include "../../include/physics_metadata.h"
#include "../../include/platform_time.h"
#include "../../include/physics_pipelining_metrics.h"
#include <string.h>
#include <stdlib.h> /* malloc/free */
/* ───── Forward declarations so registration sees these symbols ───── */
static void defining_runtime_create(VM * vm);
static void defining_runtime_constant(VM * vm);
static void defining_runtime_variable(VM * vm);
static void defining_runtime_lit(VM * vm);
static void defining_runtime_dodoes(VM * vm);
static void defining_runtime_does_rt(VM * vm);
static void defining_word_colon(VM * vm);
static void defining_word_semicolon(VM * vm);
static void defining_word_create(VM * vm);
static void defining_word_constant(VM * vm);
static void defining_word_variable(VM * vm);
static void defining_word_left_bracket(VM * vm);
static void defining_word_right_bracket(VM * vm);
static void defining_word_state(VM * vm);
static void defining_word_compile(VM * vm);
static void defining_word_bracket_compile(VM * vm);
static void defining_word_literal(VM * vm);
static void defining_word_does(VM * vm);
static void defining_word_immediate(VM * vm);
static void dictionary_word_forget(VM * vm);
static void dictionary_word_fence(VM * vm);
/* ───────────────────────────── Runtimes ───────────────────────────── */
/* CONSTANT runtime: ( -- n ) Push stored value from header DF cell */
/**
* @brief Runtime behavior for CONSTANT words
*
* Pushes the constant value stored in the word's data field onto the stack.
* Stack effect: ( -- n )
*
* @param vm Pointer to the VM context
*/
static void defining_runtime_constant(VM *vm) {
if (!vm) return;
DictEntry *entry = vm->current_executing_entry;
if (!entry) {
vm->error = 1;
return;
}
cell_t *df = vm_dictionary_get_data_field(entry);
if (!df) {
vm->error = 1;
return;
}
vm_push(vm, *df);
log_message(LOG_DEBUG, "CONSTANT runtime: pushed %ld for %.*s",
(long) *df, entry->name_len, entry->name);
}
/* VARIABLE runtime: ( -- addr ) Push VM offset stored in header DF cell */
/**
* @brief Runtime behavior for VARIABLE words
*
* Pushes the variable's address (VM offset) stored in the word's data field.
* Stack effect: ( -- addr )
*
* @param vm Pointer to the VM context
*/
static void defining_runtime_variable(VM *vm) {
if (!vm) return;
DictEntry *entry = vm->current_executing_entry;
if (!entry) {
vm->error = 1;
return;
}
cell_t *df = vm_dictionary_get_data_field(entry);
if (!df) {
vm->error = 1;
return;
}
vm_push(vm, *df);
log_message(LOG_DEBUG, "VARIABLE runtime: pushed VM addr %ld for %.*s",
(long) *df, entry->name_len, entry->name);
}
/* CREATE runtime: ( -- addr ) Push DFA (VM byte offset) captured at CREATE */
/**
* @brief Runtime behavior for words defined by CREATE
*
* Pushes the word's data field address (DFA) captured at CREATE time.
* Stack effect: ( -- addr )
*
* @param vm Pointer to the VM context
*/
static void defining_runtime_create(VM *vm) {
if (!vm) return;
DictEntry *entry = vm->current_executing_entry;
if (!entry) {
vm->error = 1;
return;
}
cell_t *df = vm_dictionary_get_data_field(entry);
if (!df) {
vm->error = 1;
return;
}
vaddr_t dfa = (vaddr_t)(uint64_t)(*df);
if (!vm_addr_ok(vm, dfa, sizeof(cell_t))) {
vm->error = 1;
return;
}
vm_push(vm, CELL(dfa));
log_message(LOG_DEBUG, "CREATE runtime: pushed DFA %ld for %.*s",
(long) dfa, entry->name_len, entry->name);
}
/* LIT runtime: ( -- n ) — fetch next cell from threaded code via R-stack IP */
/**
* @brief Runtime behavior for literal values in threaded code
*
* Fetches the next cell from threaded code via IP and pushes it.
* Stack effect: ( -- n )
*
* @param vm Pointer to the VM context
*/
static void defining_runtime_lit(VM *vm) {
if (!vm) return;
if (vm->rsp < 0) {
vm->error = 1;
return;
}
cell_t *rip = (cell_t *) (uintptr_t) vm->return_stack[vm->rsp]; /* peek IP */
if (!rip) {
vm->error = 1;
return;
}
cell_t value = *rip; /* read literal cell */
vm_push(vm, value);
rip++; /* advance IP to after literal */
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
rip; /* write-back */
log_message(LOG_DEBUG, "LIT: pushed %ld", (long) value);
}
/* DODOES runtime: when a created word runs, push PFA+8 (user data addr) then execute DOES>-body
PFA layout: [body_vaddr][user_data...]
We push the address of user_data, then execute body_vaddr code. */
/**
* @brief Runtime behavior for words defined with DOES>
*
* Pushes the address of user data area then executes the DOES> body code.
* PFA layout: [body_vaddr][user_data...]
*
* @param vm Pointer to the VM context
*/
static void defining_runtime_dodoes(VM *vm) {
if (!vm) return;
DictEntry *self = vm->current_executing_entry;
if (!self) {
vm->error = 1;
log_message(LOG_ERROR, "DODOES: no current entry");
return;
}
cell_t *df = vm_dictionary_get_data_field(self);
if (!df) {
vm->error = 1;
return;
}
vaddr_t pfa = (vaddr_t)(uint64_t)(*df);
/* PFA[0] holds vaddr of DOES>-body */
if (!vm_addr_ok(vm, pfa, sizeof(cell_t))) {
vm->error = 1;
log_message(LOG_ERROR, "DODOES: invalid PFA address %zu", (size_t) pfa);
return;
}
vaddr_t body_vaddr = (vaddr_t)(uint64_t)(*(cell_t *) vm_ptr(vm, pfa));
log_message(LOG_DEBUG, "DODOES: body_vaddr=%zu (loaded from PFA[0] at %zu)", (size_t) body_vaddr, (size_t) pfa);
if (!vm_addr_ok(vm, body_vaddr, sizeof(cell_t))) {
vm->error = 1;
log_message(LOG_ERROR, "DODOES: invalid body_vaddr %zu", (size_t) body_vaddr);
return;
}
/* Push address of user data (PFA + sizeof(cell_t)) per DOES> semantics */
vaddr_t user_data_addr = pfa + sizeof(cell_t);
vm_push(vm, (cell_t) user_data_addr);
/* Execute like a colon word until EXIT pops the frame */
int base_rsp = vm->rsp;
cell_t *ip = (cell_t *) vm_ptr(vm, body_vaddr);
vm->rsp++;
if (vm->rsp >= STACK_SIZE) {
vm->error = 1;
vm->rsp = base_rsp;
return;
}
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
ip;
while (!vm->error && !vm->abort_requested && !vm->exit_colon && vm->rsp >= base_rsp + 1) {
cell_t *cur_ip = (cell_t *) (uintptr_t) vm->return_stack[vm->rsp];
DictEntry *entry = (DictEntry *) (uintptr_t)(*cur_ip++);
vm->return_stack[vm->rsp] = (cell_t)(uintptr_t)
cur_ip;
if (!entry || !entry->func) {
vm->error = 1;
break;
}
vm->current_executing_entry = entry;
physics_execution_heat_increment(entry);
profiler_word_count(entry);
profiler_word_enter(entry);
entry->func(vm);
physics_metadata_touch(entry, entry->execution_heat, sf_monotonic_ns());
profiler_word_exit(entry);
}
/* Handle EXIT from the DOES> body */
if (vm->exit_colon) {
vm->rsp = base_rsp;
vm->exit_colon = 0;
}
/* ABORT already reset rsp (reset_vm_state(), called synchronously by
* system_word_abort() before this loop even notices the flag) --
* restoring it to base_rsp here would partially undo that reset.
* Only clamp back up to base_rsp on a normal/EXIT completion. */
if (!vm->abort_requested && vm->rsp < base_rsp) vm->rsp = base_rsp;
}
/* does_rt: runs inside the defining word at DOES> time.
Converts the just-created child so its runtime is DODOES and
records the DOES>-body start address at the child's PFA[0].
NOTE: PFA already contains user data from , or other compile-time words.
We need to build a new PFA structure: [body_vaddr][old_user_data...]
and update the child's DF to point to this new PFA. */
/**
* @brief Helper routine executed at DOES> time
*
* Converts the just-created child word to use DODOES runtime behavior
* and records the DOES> body address in the child's PFA.
*
* @param vm Pointer to the VM context
*/
static void defining_runtime_does_rt(VM *vm) {
if (!vm) return;
DictEntry *child = vm->latest;
if (!child) {
vm->error = 1;
log_message(LOG_ERROR, "DOES>: no child to patch");
return;
}
/* IP (top R-stack) points at the next entry (EXIT we compile below); body starts after that */
if (vm->rsp < 0) {
vm->error = 1;
return;
}
cell_t *ip = (cell_t *) (uintptr_t) vm->return_stack[vm->rsp]; /* IP is a real pointer, not vaddr */
cell_t *body_ip = ip + 1; /* first entry AFTER EXIT */
vaddr_t body_vaddr = (vaddr_t)((uint8_t *) body_ip - vm->memory);
cell_t *df = vm_dictionary_get_data_field(child);
if (!df) {
vm->error = 1;
return;
}
vaddr_t old_pfa = (vaddr_t)(uint64_t)(*df);
/* Calculate how much user data was allocated between old PFA and current HERE */
vaddr_t current_here = (vaddr_t) vm->here;
size_t user_data_size = (old_pfa < current_here) ? (current_here - old_pfa) : 0;
/* Allocate new PFA: [body_vaddr][user_data...] */
vm_align(vm);
vaddr_t new_pfa = (vaddr_t) vm->here;
/* Allocate space for body_vaddr pointer */
cell_t *body_ptr = (cell_t *) vm_allot(vm, sizeof(cell_t));
if (!body_ptr) {
vm->error = 1;
return;
}
*body_ptr = (cell_t) body_vaddr;
/* Copy user data if any was allocated */
if (user_data_size > 0) {
void *user_data_dest = vm_allot(vm, user_data_size);
if (!user_data_dest) {
vm->error = 1;
return;
}
if (vm_addr_ok(vm, old_pfa, user_data_size)) {
memcpy(user_data_dest, vm_ptr(vm, old_pfa), user_data_size);
}
}
/* Update child's DF to point to new PFA */
*df = (cell_t) new_pfa;
child->func = defining_runtime_dodoes;
}
/* ───────────────────────────── Defining words ─────────────────────── */
/* CREATE ( "name" -- ) — 79: does NOT allocate data; captures cell-aligned HERE as DFA */
static void defining_word_create(VM *vm) {
if (!vm) return;
char namebuf[WORD_NAME_MAX + 1];
int nlen = vm_parse_word(vm, namebuf, sizeof(namebuf));
if (nlen <= 0) {
vm->error = 1;
return;
}
DictEntry *entry = vm_create_word(vm, namebuf, (size_t) nlen, defining_runtime_create);
if (!entry) {
vm->error = 1;
return;
}
vm_align(vm); /* align HERE for cell data */
vaddr_t dfa = (vaddr_t) vm->here;
cell_t *df = vm_dictionary_get_data_field(entry);
if (!df) {
vm->error = 1;
return;
}
*df = (cell_t)(int64_t)
dfa;
log_message(LOG_DEBUG, "CREATE: '%.*s' DFA=%ld (HERE=%ld)",
nlen, namebuf, (long) dfa, (long) vm->here);
}
/* : ( "name" -- ) begin colon definition — IMMEDIATE */
static void defining_word_colon(VM *vm) {
if (!vm) return;
/* 79: nested colon definitions are illegal */
if (vm->mode == MODE_COMPILE) {
log_message(LOG_ERROR, "Nested ':' inside a definition is not allowed");
vm->error = 1;
return;
}
char namebuf[WORD_NAME_MAX + 1];
int nlen = vm_parse_word(vm, namebuf, sizeof(namebuf));
if (nlen <= 0) {
vm->error = 1;
return;
}
vm_enter_compile_mode(vm, namebuf, (size_t) nlen);
log_message(LOG_DEBUG, ": Started definition of '%.*s'", nlen, namebuf);
}
/* ; ( -- ) end colon definition — IMMEDIATE (compiles EXIT in vm_exit_compile_mode) */
static void defining_word_semicolon(VM *vm) {
if (!vm) return;
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
return;
}
vm_exit_compile_mode(vm);
}
/* CONSTANT ( n "name" -- ) */
static void defining_word_constant(VM *vm) {
if (!vm) return;
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t value = vm_pop(vm);
char namebuf[WORD_NAME_MAX + 1];
int nlen = vm_parse_word(vm, namebuf, sizeof(namebuf));
if (nlen <= 0) {
vm->error = 1;
return;
}
DictEntry *entry = vm_create_word(vm, namebuf, (size_t) nlen, defining_runtime_constant);
if (!entry) {
vm->error = 1;
return;
}
cell_t *df = vm_dictionary_get_data_field(entry);
if (!df) {
vm->error = 1;
return;
}
*df = value;
log_message(LOG_DEBUG, "CONSTANT: '%.*s' = %ld", nlen, namebuf, (long) value);
}
/* VARIABLE ( "name" -- ) allocate one cell in VM and store its addr in header DF */
static void defining_word_variable(VM *vm) {
if (!vm) return;
char namebuf[WORD_NAME_MAX + 1];
int nlen = vm_parse_word(vm, namebuf, sizeof(namebuf));
if (nlen <= 0) {
vm->error = 1;
return;
}
vm_align(vm);
vaddr_t addr = (vaddr_t) vm->here;
void *p = vm_allot(vm, sizeof(cell_t));
if (!p) {
vm->error = 1;
return;
}
*(cell_t *) p = 0;
DictEntry *entry = vm_create_word(vm, namebuf, (size_t) nlen, defining_runtime_variable);
if (!entry) {
vm->error = 1;
return;
}
cell_t *df = vm_dictionary_get_data_field(entry);
if (!df) {
vm->error = 1;
return;
}
*df = (cell_t)(int64_t)
addr;
log_message(LOG_DEBUG, "VARIABLE: '%.*s' at VM addr %ld", nlen, namebuf, (long) addr);
}
/* [ ( -- ) enter interpret state — IMMEDIATE */
static void defining_word_left_bracket(VM *vm) {
if (!vm) return;
/* Forth-79 requires STATE to be 0 for interpret and non-zero (typically -1) for compile */
vm_store_cell(vm, vm->state_addr, 0);
vm->mode = MODE_INTERPRET;
log_message(LOG_DEBUG, "[: interpret mode");
}
/* ] ( -- ) enter compile state — IMMEDIATE */
static void defining_word_right_bracket(VM *vm) {
if (!vm) return;
vm_store_cell(vm, vm->state_addr, (cell_t) - 1);
vm->mode = MODE_COMPILE;
log_message(LOG_DEBUG, "]: compile mode");
}
/* STATE ( -- addr ) push VM addr of STATE cell */
static void defining_word_state(VM *vm) {
if (!vm) return;
vm_push(vm, (cell_t) vm->state_addr);
}
/* COMPILE ( "word" -- ) — IMMEDIATE (legacy) */
static void defining_word_compile(VM *vm) {
if (!vm) return;
char namebuf[WORD_NAME_MAX + 1];
int nlen = vm_parse_word(vm, namebuf, sizeof(namebuf));
if (nlen <= 0) {
vm->error = 1;
return;
}
DictEntry *entry = vm_find_word(vm, namebuf, (size_t) nlen);
if (!entry) {
vm->error = 1;
return;
}
vm_compile_word(vm, entry);
log_message(LOG_DEBUG, "COMPILE: compiled '%.*s'", nlen, namebuf);
}
/* [COMPILE] ( "word" -- ) — IMMEDIATE: compile even if the word is IMMEDIATE */
static void defining_word_bracket_compile(VM *vm) {
defining_word_compile(vm);
}
/* LITERAL ( n -- ) — IMMEDIATE: compile a literal */
static void defining_word_literal(VM *vm) {
if (!vm) return;
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t v = vm_pop(vm);
vm_compile_literal(vm, v);
log_message(LOG_DEBUG, "LITERAL: compiled %ld", (long) v);
}
/* FORGET ( "name" -- ) remove target and newer words; rewind HERE to target DFA */
static void dictionary_word_forget(VM *vm) {
if (!vm) return;
char namebuf[WORD_NAME_MAX + 1];
int nlen = vm_parse_word(vm, namebuf, sizeof(namebuf));
if (nlen <= 0) {
vm->error = 1;
return;
}
int forget_failed = 0;
sf_mutex_lock(&vm->dict_lock);
/* Find target */
DictEntry *e = vm->latest;
DictEntry *target = NULL;
while (e) {
if (!(e->flags & WORD_HIDDEN) &&
e->name_len == (uint8_t) nlen &&
memcmp(e->name, namebuf, (size_t) nlen) == 0) {
target = e;
break;
}
e = e->link;
}
if (!target) {
vm->error = 1;
forget_failed = 1;
goto forget_exit;
}
/* Ensure target is NEWER than the fence */
int allowed = 0;
for (e = vm->latest; e; e = e->link) {
if (e == target) {
allowed = 1;
break;
}
if (e == vm->dict_fence_latest) break;
}
if (!allowed) {
vm->error = 1;
forget_failed = 1;
goto forget_exit;
}
/* Compute new HERE from target’s DFA (bounded by fence HERE) */
vaddr_t new_here = (vaddr_t) vm->here;
cell_t *df = vm_dictionary_get_data_field(target);
if (df) {
vaddr_t dfa = (vaddr_t)(uint64_t)(*df);
if (vm_addr_ok(vm, dfa, 0)) {
vaddr_t fence_here = (vaddr_t) vm->dict_fence_here;
new_here = (dfa < fence_here) ? fence_here : dfa;
}
} else {
new_here = (vaddr_t) vm->dict_fence_here;
}
/* Save target's link before freeing (needed for relinking) */
DictEntry *target_next = target->link;
/* Free headers from latest down to and including target, stopping before fence */
e = vm->latest;
while (e && e != vm->dict_fence_latest) {
DictEntry *next = e->link;
int is_target = (e == target);
vm_dictionary_untrack_entry(vm, e);
/* Free transition metrics before freeing entry */
if (e->transition_metrics) {
transition_metrics_cleanup(e->transition_metrics);
free(e->transition_metrics);
e->transition_metrics = NULL;
}
free(e);
if (is_target) break;
e = next;
}
/* Relink: FORGET removes target and everything newer (closer to
* vm->latest) -- the free loop above just freed every entry from
* vm->latest through target inclusive, which by definition includes
* any entry between them. There is nothing left to "skip past" --
* target_next (target's own surviving link) is always the correct
* new head, whether or not target was vm->latest itself. (Previously
* this branched on whether an entry existed between vm->latest and
* target, and relinked through it -- but that entry was always inside
* the just-freed range, making it a use-after-free on every FORGET of
* a non-latest word.) */
vm->latest = target_next;
vm->here = (size_t) new_here;
log_message(LOG_DEBUG, "FORGET: forgot '%.*s'; HERE=%ld (fence HERE=%ld)",
nlen, namebuf, (long) vm->here, (long) vm->dict_fence_here);
forget_exit:
sf_mutex_unlock(&vm->dict_lock);
if (forget_failed)
return;
}
/* FENCE ( -- ) raise the FORGET boundary to the current dictionary top.
* dict_fence_latest/dict_fence_here already exist and are already honored
* by FORGET (set once at bootstrap, protecting the base wordset); this is
* the first word exposing that state so callers can advance it further --
* e.g. an SDK capsule calling FENCE after loading protects its own
* definitions the same way the base wordset is already protected. */
static void dictionary_word_fence(VM *vm) {
if (!vm) return;
sf_mutex_lock(&vm->dict_lock);
vm->dict_fence_latest = vm->latest;
vm->dict_fence_here = vm->here;
sf_mutex_unlock(&vm->dict_lock);
log_message(LOG_DEBUG, "FENCE: raised to HERE=%ld", (long) vm->dict_fence_here);
}
/* DOES> — IMMEDIATE: finalize the defining word’s create-part and compile DOES>-body */
static void defining_word_does(VM *vm) {
if (!vm) return;
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
log_message(LOG_ERROR, "DOES>: compile-only");
return;
}
/* Compile helper (void fn; check vm->error after) */
vm_compile_call(vm, defining_runtime_does_rt);
if (vm->error) {
log_message(LOG_ERROR, "DOES>: could not compile does_rt");
return;
}
/* Compile EXIT so the defining word returns immediately after patching */
DictEntry *exitw = vm_find_word(vm, "EXIT", 4);
if (!exitw) {
vm->error = 1;
log_message(LOG_ERROR, "DOES>: EXIT not found");
return;
}
vm_compile_word(vm, exitw);
if (vm->error) return;
/* Continue compiling: the following words form the DOES>-body executed by DODOES later. */
}
/* IMMEDIATE ( -- ) mark latest word immediate — IMMEDIATE itself */
static void defining_word_immediate(VM *vm) {
if (!vm) return;
if (!vm->latest) {
vm->error = 1;
return;
}
vm->latest->flags |= WORD_IMMEDIATE;
log_message(LOG_DEBUG, "IMMEDIATE: marked '%.*s' immediate",
(int) vm->latest->name_len, vm->latest->name);
}
/* ───────────────────────────── DEFER / IS ─────────────────────────── */
/* DEFER/IS/DEFER@ are NOT defined here: defer_words.c registers the same
* three names later in boot order (word_registry.c Module 27 vs this
* file's Module 17), and it has no __STARKERNEL__ guard, so it shadows
* this file's versions in both hosted and kernel builds. FORTH's
* newest-first dictionary lookup means defer_words.c's versions (a
* self-contained implementation, unrelated to this file's former
* defining_runtime_defer) are the only ones ever reachable. See
* proof/StarForth_Defer_Words.thy and proof/FINDINGS.md §3. */
/* ───────────────────────────── Registration ───────────────────────── */
/**
* @brief Register all defining words in the dictionary
*
* Registers core defining words like :, ;, CREATE, CONSTANT, VARIABLE,
* and their support words like IMMEDIATE, STATE, etc.
*
* @param vm Pointer to the VM context
*/
void register_defining_words(VM *vm) {
/* Core colon pair — both IMMEDIATE */
register_word(vm, ":", defining_word_colon);
vm_make_immediate(vm);
register_word(vm, ";", defining_word_semicolon);
vm_make_immediate(vm);
/* CREATE / VARIABLE / CONSTANT */
register_word(vm, "CREATE", defining_word_create);
register_word(vm, "VARIABLE", defining_word_variable);
register_word(vm, "CONSTANT", defining_word_constant);
/* IMMEDIATE (make IMMEDIATE itself immediate) */
register_word(vm, "IMMEDIATE", defining_word_immediate);
vm_make_immediate(vm);
/* STATE and mode switchers */
register_word(vm, "STATE", defining_word_state);
register_word(vm, "[", defining_word_left_bracket);
vm_make_immediate(vm);
register_word(vm, "]", defining_word_right_bracket);
vm_make_immediate(vm);
/* Dictionary management */
register_word(vm, "FORGET", dictionary_word_forget);
register_word(vm, "FENCE", dictionary_word_fence);
/* Compile helpers — immediate */
register_word(vm, "COMPILE", defining_word_compile);
vm_make_immediate(vm);
register_word(vm, "[COMPILE]", defining_word_bracket_compile);
vm_make_immediate(vm);
/* LIT runtime + LITERAL (immediate) */
register_word(vm, "LIT", defining_runtime_lit);
register_word(vm, "LITERAL", defining_word_literal);
vm_make_immediate(vm);
/* DOES> plumbing (lowercase internal helper visible for tests/trace) */
register_word(vm, "does_rt", defining_runtime_does_rt); /* internal helper */
register_word(vm, "DOES>", defining_word_does);
vm_make_immediate(vm);
}
v3/src/word_source/dictionary_heat_diagnostic_words.c
+287
View File
@@ -0,0 +1,287 @@
/*
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.
*/
/*
*** StarForth ***
dictionary_heat_diagnostic_words.c - FORTH Interface for Dictionary Heat Optimization
Introspection words to observe and control heat-aware dictionary lookup behavior.
*/
#include <stdio.h>
#include <stdint.h>
#include <string.h>
#include "vm.h"
#include "word_registry.h"
#include "platform_time.h"
#include "dictionary_heat_optimization.h"
/**
* @brief HEAT-PERCENTILES ( -- 25th 50th 75th )
*
* Pushes the three heat percentile thresholds currently used by the
* heat-aware dictionary lookup strategy: @c heat_threshold_25th,
* @c heat_threshold_50th, and @c heat_threshold_75th. These are updated
* by @c dict_update_heat_percentiles() during bucket reorganisation.
*
* Stack effect: ( -- 25th 50th 75th ) TOS = 75th
*
* @param vm Active VM; sets @c vm->error = 1 on stack overflow
*/
void forth_HEAT_PERCENTILES(VM *vm) {
if (vm->error) return;
if (vm->dsp + 3 > STACK_SIZE) {
vm->error = 1;
return;
}
vm->data_stack[vm->dsp++] = vm->heat_threshold_25th;
vm->data_stack[vm->dsp++] = vm->heat_threshold_50th;
vm->data_stack[vm->dsp++] = vm->heat_threshold_75th;
}
/**
* @brief LOOKUP-STRATEGY@ ( -- strategy )
*
* Pushes the current dictionary lookup strategy: 0 = naive (newest-first
* linear scan), 1 = heat-aware (hot-bucket-first).
*
* Stack effect: ( -- strategy )
*
* @param vm Active VM; sets @c vm->error = 1 on stack overflow
*/
void forth_LOOKUP_STRATEGY_FETCH(VM *vm) {
if (vm->error) return;
if (vm->dsp >= STACK_SIZE) {
vm->error = 1;
return;
}
vm->data_stack[vm->dsp++] = (cell_t)vm->lookup_strategy;
}
/**
* @brief LOOKUP-STRATEGY! ( strategy -- )
*
* Sets @c vm->lookup_strategy to @c strategy. Only values 0 (naive) and
* 1 (heat-aware) are accepted; out-of-range values are silently discarded.
*
* Stack effect: ( strategy -- )
*
* @param vm Active VM; sets @c vm->error = 1 on stack underflow
*/
void forth_LOOKUP_STRATEGY_STORE(VM *vm) {
if (vm->error) return;
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t strategy = vm->data_stack[--vm->dsp];
if (strategy == 0 || strategy == 1) {
vm->lookup_strategy = (int)strategy;
}
}
/**
* @brief REORG-BUCKETS ( -- )
*
* Immediately triggers @c dict_reorganize_buckets_by_heat() followed by
* @c dict_update_heat_percentiles() to re-sort the dictionary's lookup
* buckets by current execution heat and refresh the percentile thresholds.
* Normally this happens automatically on a heartbeat cycle; this word forces
* it on-demand for testing or after a large batch of @c HEAT! assignments.
*
* Stack effect: ( -- )
*
* @param vm Active VM; no-op if @c vm->error is set
*/
void forth_REORG_BUCKETS(VM *vm) {
if (vm->error) return;
dict_reorganize_buckets_by_heat(vm);
dict_update_heat_percentiles(vm);
}
/**
* @brief SHOW-HEAT-OPTIMIZATION ( -- )
*
* Prints a summary of the current dictionary heat optimization state to
* @c stdout: the active lookup strategy (naive or heat-aware), the three
* percentile threshold values, and the resulting hot/warm/cool heat zones.
* Intended for interactive diagnostics.
*
* Stack effect: ( -- )
*
* @param vm Active VM; no-op if @c vm->error is set
*/
void forth_SHOW_HEAT_OPTIMIZATION(VM *vm) {
if (vm->error) return;
printf("\n=== Dictionary Heat Optimization Status ===\n");
printf("Lookup Strategy: ");
if (vm->lookup_strategy == 0) {
printf("NAIVE (newest-first search)\n");
} else if (vm->lookup_strategy == 1) {
printf("HEAT-AWARE (hot words first)\n");
} else {
printf("UNKNOWN (%d)\n", vm->lookup_strategy);
}
printf("Heat Percentile Thresholds:\n");
printf(" 25th percentile: %ld\n", vm->heat_threshold_25th);
printf(" 50th percentile: %ld\n", vm->heat_threshold_50th);
printf(" 75th percentile: %ld\n", vm->heat_threshold_75th);
printf("\nHeat Zones:\n");
printf(" TOP 25%% (hot) : >= %ld heat\n", vm->heat_threshold_75th);
printf(" MIDDLE 50%% (warm) : %ld - %ld heat\n",
vm->heat_threshold_25th, vm->heat_threshold_75th);
printf(" BOTTOM 25%% (cool) : < %ld heat\n", vm->heat_threshold_25th);
printf("\n");
}
/**
* @brief COMPARE-LOOKUPS ( iterations -- )
*
* Micro-benchmark that measures naive vs heat-aware dictionary lookup
* performance over @c iterations passes through six common test words
* (DUP, DROP, SWAP, @, !, EMIT). Prints elapsed time in milliseconds and
* the percentage speedup (or slowdown) for heat-aware vs naive. Restores
* the original @c vm->lookup_strategy on completion. Intended for
* interactive diagnostics; not used in DoE mode.
*
* Stack effect: ( iterations -- )
*
* @param vm Active VM; sets @c vm->error = 1 on underflow or non-positive @c iterations
*/
void forth_COMPARE_LOOKUPS(VM *vm) {
if (vm->error) return;
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t iterations = vm->data_stack[--vm->dsp];
if (iterations <= 0) {
printf("Need positive iteration count\n");
return;
}
printf("\n=== Dictionary Lookup Comparison ===\n");
printf("Iterations: %ld\n", iterations);
/* Common test words */
const char *test_words[] = {"DUP", "DROP", "SWAP", "@", "!", "EMIT", NULL};
/* Strategy 1: Naive (current strategy) */
printf("\nNaive (newest-first) lookup:\n");
int orig_strategy = vm->lookup_strategy;
vm->lookup_strategy = 0;
uint64_t start_ns = sf_monotonic_ns();
for (cell_t i = 0; i < iterations; i++) {
for (int j = 0; test_words[j]; j++) {
vm_find_word(vm, test_words[j], strlen(test_words[j]));
}
}
uint64_t naive_ns = sf_monotonic_ns() - start_ns;
/* Strategy 2: Heat-aware */
printf("Heat-aware lookup:\n");
dict_reorganize_buckets_by_heat(vm);
vm->lookup_strategy = 1;
start_ns = sf_monotonic_ns();
for (cell_t i = 0; i < iterations; i++) {
for (int j = 0; test_words[j]; j++) {
vm_find_word(vm, test_words[j], strlen(test_words[j]));
}
}
uint64_t heat_ns = sf_monotonic_ns() - start_ns;
/* Restore original strategy */
vm->lookup_strategy = orig_strategy;
/* Report results_run_01_2025_12_08 */
printf("\n=== Benchmark Results ===\n");
printf("Naive time: %.3f ms\n", (double)naive_ns / 1000000.0);
printf("Heat-aware time: %.3f ms\n", (double)heat_ns / 1000000.0);
if (heat_ns > 0) {
double speedup = (double)naive_ns / (double)heat_ns;
if (speedup > 1.0) {
printf("Speedup: %.2f%% faster\n", (speedup - 1.0) * 100.0);
} else {
printf("Slowdown: %.2f%% slower\n", (1.0 - speedup) * 100.0);
}
}
printf("\n");
}
/**
* @brief Register all dictionary heat diagnostic words with the VM dictionary.
*
* Registers: @c HEAT-PERCENTILES, @c LOOKUP-STRATEGY@, @c LOOKUP-STRATEGY!,
* @c REORG-BUCKETS, @c SHOW-HEAT-OPTIMIZATION, @c COMPARE-LOOKUPS.
* Called during VM bootstrap.
*
* @param vm Active VM to register words into
*/
void register_dictionary_heat_diagnostic_words(VM *vm) {
register_word(vm, "HEAT-PERCENTILES", forth_HEAT_PERCENTILES);
register_word(vm, "LOOKUP-STRATEGY@", forth_LOOKUP_STRATEGY_FETCH);
register_word(vm, "LOOKUP-STRATEGY!", forth_LOOKUP_STRATEGY_STORE);
register_word(vm, "REORG-BUCKETS", forth_REORG_BUCKETS);
register_word(vm, "SHOW-HEAT-OPTIMIZATION", forth_SHOW_HEAT_OPTIMIZATION);
register_word(vm, "COMPARE-LOOKUPS", forth_COMPARE_LOOKUPS);
}
v3/src/word_source/dictionary_manipulation_words.c
+469
View File
@@ -0,0 +1,469 @@
/*
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.
*/
/* dictionary_manipulation_words.c - FORTH-79 Dictionary Manipulation Words */
#include "include/dictionary_manipulation_words.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
/* Global state for dictionary manipulation */
static cell_t state_variable = 0; /* STATE - compilation state */
/* Helper function to calculate aligned address */
static uintptr_t align_address(uintptr_t addr) {
size_t alignment = sizeof(cell_t);
return (addr + alignment - 1) & ~(alignment - 1);
}
/* Helper function to get name field from execution token */
static char *get_name_field(DictEntry *entry) {
if (entry == NULL) {
return NULL;
}
return (char *) entry->name;
}
/* Helper function to get body address from execution token */
static void *get_body_address(DictEntry *entry) {
if (entry == NULL) {
return NULL;
}
/* Body follows the header structure */
uintptr_t body_addr = (uintptr_t) entry + sizeof(DictEntry) + entry->name_len;
return (void *) align_address(body_addr);
}
/* Helper function to find dictionary entry from name field */
static DictEntry *find_entry_from_name(VM *vm, char *name_field) {
DictEntry *entry;
entry = vm->latest;
while (entry != NULL) {
if ((char *) entry->name == name_field) {
return entry;
}
entry = entry->link;
}
return NULL;
}
/* Helper function to traverse name field */
static char *traverse_name_field(char *name_addr, int direction) {
uint8_t *ptr;
uint8_t name_len;
if (name_addr == NULL) {
return NULL;
}
/* FORTH-79 names start with length byte */
ptr = (uint8_t *) name_addr;
if (direction > 0) {
/* Forward traversal - skip over name */
name_len = *ptr & 0x1F; /* Mask off flags */
return (char *) (ptr + name_len + 1);
} else {
/* Backward traversal - find start of name */
/* This is more complex - we need to scan backwards */
/* For simplicity, assume we're at the start already */
return name_addr;
}
}
/**
* @brief FORTH word SMUDGE - Toggle smudge bit of latest word
* @param vm Pointer to VM instance
* @stack ( -- )
* @note Compile-only word
*/
static void dictionary_m_word_smudge(VM *vm) {
// compile-only: error if used while interpreting
if (vm->mode != MODE_COMPILE) {
// correct
vm->error = 1;
return;
}
// existing body that toggles/sets the smudge/hidden bit on the *latest* word
// (leave your current logic exactly as-is)
}
/* >BODY ( xt -- addr ) Convert execution token to body */
void dictionary_m_word_to_body(VM *vm) {
if (vm->dsp < 0) {
log_message(LOG_ERROR, ">BODY: Stack underflow");
vm->error = 1;
return;
}
cell_t xt = vm_pop(vm);
log_message(LOG_DEBUG, ">BODY: POP: %ld (dsp=%d)", (long) xt, vm->dsp);
DictEntry *entry = (DictEntry *) (intptr_t) xt;
if (!entry) {
log_message(LOG_ERROR, ">BODY: Invalid execution token (NULL)");
vm->error = 1;
return;
}
// Use the VM's dictionary function to get the data field
cell_t *data_field = vm_dictionary_get_data_field(entry);
if (!data_field) {
log_message(LOG_ERROR, ">BODY: Unable to get data field address for entry %p", (void *) entry);
vm->error = 1;
return;
}
cell_t body_addr = (cell_t)(intptr_t)data_field;
log_message(LOG_DEBUG, ">BODY: xt=%p -> body=%p", (void *) entry, (void *) data_field);
vm_push(vm, body_addr);
log_message(LOG_DEBUG, ">BODY: PUSH: %ld (dsp=%d)", (long) body_addr, vm->dsp);
}
/* >NAME ( xt -- addr ) Convert execution token to name */
void dictionary_m_word_to_name(VM *vm) {
cell_t xt;
DictEntry *entry;
char *name_field;
if (vm->dsp < 0) {
vm->error = 1;
return;
}
xt = vm_pop(vm);
entry = (DictEntry *) (uintptr_t) xt;
name_field = get_name_field(entry);
if (name_field == NULL) {
vm->error = 1;
return;
}
vm_push(vm, (cell_t)(uintptr_t)name_field);
}
/* NAME> ( addr -- xt ) Convert name to execution token */
void dictionary_m_word_name_to(VM *vm) {
cell_t addr;
char *name_field;
DictEntry *entry;
if (vm->dsp < 0) {
vm->error = 1;
return;
}
addr = vm_pop(vm);
name_field = (char *) (uintptr_t) addr;
entry = find_entry_from_name(vm, name_field);
if (entry == NULL) {
vm->error = 1;
return;
}
vm_push(vm, (cell_t)(uintptr_t)entry);
}
/* >LINK ( addr -- addr ) Get link field address */
void dictionary_m_word_to_link(VM *vm) {
cell_t addr;
DictEntry *entry;
if (vm->dsp < 0) {
vm->error = 1;
return;
}
addr = vm_pop(vm);
entry = (DictEntry *) (uintptr_t) addr;
if (entry == NULL) {
vm->error = 1;
return;
}
/* Link field is part of the DictEntry structure */
vm_push(vm, (cell_t)(uintptr_t) & entry->link);
}
/* LINK> ( addr -- addr ) Get next word from link */
void dictionary_m_word_link_from(VM *vm) {
cell_t addr;
DictEntry **link_field;
DictEntry *next_entry;
if (vm->dsp < 0) {
vm->error = 1;
return;
}
addr = vm_pop(vm);
link_field = (DictEntry **) (uintptr_t) addr;
if (link_field == NULL) {
vm->error = 1;
return;
}
next_entry = *link_field;
vm_push(vm, (cell_t)(uintptr_t)next_entry);
}
/* CFA ( addr -- xt ) Get code field address */
void dictionary_m_word_cfa(VM *vm) {
cell_t addr;
DictEntry *entry;
if (vm->dsp < 0) {
vm->error = 1;
return;
}
addr = vm_pop(vm);
entry = (DictEntry *) (uintptr_t) addr;
if (entry == NULL) {
vm->error = 1;
return;
}
/* In our implementation, the execution token is the entry itself */
vm_push(vm, (cell_t)(uintptr_t)entry);
}
/* LFA ( addr -- addr ) Get link field address */
void dictionary_m_word_lfa(VM *vm) {
dictionary_m_word_to_link(vm); /* Same as >LINK */
}
/* NFA ( addr -- addr ) Get name field address */
void dictionary_m_word_nfa(VM *vm) {
cell_t addr;
DictEntry *entry;
char *name_field;
if (vm->dsp < 0) {
vm->error = 1;
return;
}
addr = vm_pop(vm);
entry = (DictEntry *) (uintptr_t) addr;
name_field = get_name_field(entry);
if (name_field == NULL) {
vm->error = 1;
return;
}
vm_push(vm, (cell_t)(uintptr_t)name_field);
}
/* PFA ( addr -- addr ) Get parameter field address */
void dictionary_m_word_pfa(VM *vm) {
cell_t addr;
DictEntry *entry;
void *body_addr;
if (vm->dsp < 0) {
vm->error = 1;
return;
}
addr = vm_pop(vm);
entry = (DictEntry *) (uintptr_t) addr;
body_addr = get_body_address(entry);
if (body_addr == NULL) {
vm->error = 1;
return;
}
vm_push(vm, (cell_t)(uintptr_t)body_addr);
}
/* TRAVERSE ( addr n -- addr ) Move through name field */
void dictionary_m_word_traverse(VM *vm) {
cell_t n, addr;
char *name_addr;
char *result_addr;
if (vm->dsp < 1) {
vm->error = 1;
return;
}
n = vm_pop(vm);
addr = vm_pop(vm);
name_addr = (char *) (uintptr_t) addr;
result_addr = traverse_name_field(name_addr, (int) n);
if (result_addr == NULL) {
vm->error = 1;
return;
}
vm_push(vm, (cell_t)(uintptr_t)result_addr);
}
/* INTERPRET ( -- ) Text interpreter */
void dictionary_m_word_interpret(VM *vm) {
/* Simply call the VM's built-in interpreter - it handles everything */
/* The VM already has proper input management, word parsing, and execution */
/* In FORTH-79, INTERPRET processes the current input stream */
/* Since vm_interpret handles input parsing and execution, we just ensure */
/* we're in the right mode and let the VM do the work */
/* Set interpretation mode */
vm->mode = MODE_INTERPRET;
state_variable = 0;
/* The actual interpretation happens through vm_interpret() calls */
/* This word exists mainly for completeness and mode setting */
}
static void dictionary_m_word_find(VM *vm) {
char namebuf[128];
int nlen = vm_parse_word(vm, namebuf, sizeof namebuf);
if (nlen <= 0) {
vm->error = 1; // real input underflow
return;
}
DictEntry *e = vm_find_word(vm, namebuf, (size_t) nlen);
if (e) {
vm_push(vm, (cell_t)(uintptr_t)e); // compilation address; swap to CFA if you prefer later
} else {
vm_push(vm, 0); // miss is NOT an error
}
}
/* ' ( -- xt ) FORTH-79 tick: parse next word, push its execution token.
* Non-immediate — in compile mode the interpreter compiles a call to ',
* so this function only ever runs in interpret mode. */
static void dictionary_m_word_tick(VM *vm) {
char namebuf[128];
int nlen = vm_parse_word(vm, namebuf, sizeof namebuf);
if (nlen <= 0) {
log_message(LOG_ERROR, "': unable to parse word");
vm->error = 1;
return;
}
DictEntry *e = vm_find_word(vm, namebuf, (size_t) nlen);
if (!e) {
log_message(LOG_ERROR, "': word '%.*s' not found", nlen, namebuf);
vm->error = 1;
return;
}
log_message(LOG_DEBUG, "': found '%.*s' xt=%p", nlen, namebuf, (void *) e);
vm_push(vm, (cell_t)(uintptr_t)e);
}
// in src/word_source/dictionary_manipulation_words.c
static void dictionary_m_word_hidden(VM *vm) {
// compile-only guard (matches your other compile-only words)
if (vm->mode != MODE_COMPILE) {
vm->error = 1;
return;
}
// get the latest entry (use whatever you use elsewhere; many places access vm->latest)
DictEntry *e = vm->latest;
if (!e) {
vm->error = 1;
return;
}
// Set the hidden/smudge flag. Prefer a named flag if you have it.
// If your codebase uses WORD_HIDDEN, use that.
// If it uses the same bit as SMUDGE, use that (often called WORD_SMUDGED).
#ifdef WORD_HIDDEN
e->flags |= WORD_HIDDEN;
#else
// Fallback: if you only have a toggling SMUDGE path, set conditionally using it.
if (!(e->flags & WORD_SMUDGED)) {
// call your existing SMUDGE implementation to flip it on once
dictionary_word_smudge(vm);
// ensure we didn't accidentally set an error
if (vm->error) return;
}
#endif
}
/*
* @brief Register all dictionary manipulation words with the VM
* @param vm Pointer to VM instance
* @details Registers standard FORTH-79 dictionary manipulation words
*/
void register_dictionary_manipulation_words(VM *vm) {
/* Register all dictionary manipulation words */
/* [, ], STATE are NOT registered here: defining_words.c registers the
* same three names later in boot order (word_registry.c Module 17 vs
* this file's Module 13), and FORTH's newest-first dictionary lookup
* means defining_words.c's versions are the only ones ever reachable.
* The versions formerly here also wrote a dead file-scope static
* instead of vm->state_addr -- see proof/StarForth_Defining_Words.thy
* and proof/FINDINGS.md §1. */
register_word(vm, "SMUDGE", dictionary_m_word_smudge);
register_word(vm, "HIDDEN", dictionary_m_word_hidden);
register_word(vm, ">BODY", dictionary_m_word_to_body);
register_word(vm, ">NAME", dictionary_m_word_to_name);
register_word(vm, "NAME>", dictionary_m_word_name_to);
register_word(vm, ">LINK", dictionary_m_word_to_link);
register_word(vm, "LINK>", dictionary_m_word_link_from);
register_word(vm, "CFA", dictionary_m_word_cfa);
register_word(vm, "LFA", dictionary_m_word_lfa);
register_word(vm, "NFA", dictionary_m_word_nfa);
register_word(vm, "PFA", dictionary_m_word_pfa);
register_word(vm, "TRAVERSE", dictionary_m_word_traverse);
register_word(vm, "INTERPRET", dictionary_m_word_interpret);
register_word(vm, "FIND", dictionary_m_word_find);
register_word(vm, "'", dictionary_m_word_tick);
}
v3/src/word_source/dictionary_words.c
+224
View File
@@ -0,0 +1,224 @@
/*
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/dictionary_words.h"
#include "../../include/word_registry.h"
#include "vm.h"
#include "../../include/log.h"
/* === SAFE DICTIONARY WORDS IMPLEMENTATION (addresses are VM offsets) === */
/**
* @brief HERE ( -- addr ) Returns the dictionary pointer
* @param vm Pointer to the VM structure
*/
void dictionary_word_here(VM *vm) {
vm_push(vm, vm->here);
}
static void dictionary_word_align(VM *vm) {
vm_align(vm);
}
/**
* @brief ALLOT ( n -- ) Allocate n bytes in dictionary
* @param vm Pointer to the VM structure
* @details Allocates n bytes in the dictionary. n can be negative to deallocate space
*/
void dictionary_word_allot(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
cell_t new_here = vm->here + n;
/* Dictionary growth is bounded to DICTIONARY_MEMORY_SIZE, not the full
* VM_MEMORY_SIZE: blocks >= USER_BLOCKS_START live in the same flat
* vm->memory array (see vm_get_block_addr), so letting `here` grow past
* the dictionary region would silently corrupt live block/user data. */
if (new_here < 0 || new_here > (cell_t) DICTIONARY_MEMORY_SIZE) {
vm->error = 1;
return;
}
vm->here = new_here;
}
/**
* @brief , ( n -- ) Compile cell into dictionary
* @param vm Pointer to the VM structure
* @details Compiles a single cell value into the dictionary at HERE
*/
void dictionary_word_comma(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
vm_align(vm);
if (vm->here + (cell_t) sizeof(cell_t) > DICTIONARY_MEMORY_SIZE) {
vm->error = 1;
return;
}
vaddr_t addr = VM_ADDR(vm->here);
if (!vm_addr_ok(vm, addr, sizeof(cell_t))) {
vm->error = 1;
return;
}
vm_store_cell(vm, addr, n);
vm->here += sizeof(cell_t);
}
/**
* @brief C, ( c -- ) Compile byte into dictionary
* @param vm Pointer to the VM structure
* @details Compiles a single byte value into the dictionary at HERE
*/
void dictionary_word_c_comma(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t c = vm_pop(vm);
if (vm->here + 1 > DICTIONARY_MEMORY_SIZE) {
vm->error = 1;
return;
}
vaddr_t a = VM_ADDR(vm->here);
if (!vm_addr_ok(vm, a, 1)) {
vm->error = 1;
return;
}
vm_store_u8(vm, a, (uint8_t)(c & 0xFF));
vm->here += 1;
}
/**
* @brief 2, ( d -- ) Compile double-cell into dictionary
* @param vm Pointer to the VM structure
* @details Compiles a double cell value into the dictionary at HERE, low cell first
*/
void dictionary_word_2comma(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t high = vm_pop(vm);
cell_t low = vm_pop(vm);
vm_align(vm);
if (vm->here + (cell_t)(2 * sizeof(cell_t)) > DICTIONARY_MEMORY_SIZE) {
vm->error = 1;
return;
}
vaddr_t a = VM_ADDR(vm->here);
if (!vm_addr_ok(vm, a, 2 * sizeof(cell_t))) {
vm->error = 1;
return;
}
vm_store_cell(vm, a, low);
vm_store_cell(vm, a + sizeof(cell_t), high);
vm->here += 2 * sizeof(cell_t);
}
/**
* @brief PAD ( -- addr ) Get scratch pad buffer address
* @param vm Pointer to the VM structure
* @details Returns VM address of 512-byte temporary text buffer at top of memory
*/
void dictionary_word_pad(VM *vm) {
size_t pad_offset = VM_MEMORY_SIZE - 512;
vm_push(vm, (cell_t) pad_offset);
}
/**
* @brief SP@ ( -- sp ) Get current stack pointer
* @param vm Pointer to the VM structure
* @details Returns the current stack-pointer index (top is 0)
*/
void dictionary_word_sp_fetch(VM *vm) {
/* No stack args required */
vm_push(vm, (cell_t) vm->dsp);
}
/**
* @brief SP! ( sp -- ) Set stack pointer
* @param vm Pointer to the VM structure
* @details Restores the stack-pointer, but never allows growing the stack
*/
void dictionary_word_sp_store(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
} /* need one arg */
cell_t new_sp = vm_pop(vm);
/* Valid range: -1 (empty stack) up to current dsp (can shrink, not grow) */
if (new_sp < -1 || new_sp > vm->dsp) {
vm->error = 1;
return;
}
vm->dsp = new_sp;
/* We don’t need to scrub values above dsp; they’re considered garbage/unused. */
}
/**
* @brief LATEST ( -- addr ) Get latest definition address
* @param vm Pointer to the VM structure
* @details Returns VM address near most recent compiled definition (end of dictionary)
*/
void dictionary_word_latest(VM *vm) {
vm_push(vm, vm->here);
}
/* Registration */
void register_dictionary_words(VM *vm) {
register_word(vm, "HERE", dictionary_word_here);
register_word(vm, "ALIGN", dictionary_word_align);
register_word(vm, "ALLOT", dictionary_word_allot);
register_word(vm, ",", dictionary_word_comma);
register_word(vm, "C,", dictionary_word_c_comma);
register_word(vm, "2,", dictionary_word_2comma);
register_word(vm, "PAD", dictionary_word_pad);
register_word(vm, "SP!", dictionary_word_sp_store);
register_word(vm, "SP@", dictionary_word_sp_fetch);
register_word(vm, "LATEST", dictionary_word_latest);
}
v3/src/word_source/double_words.c
+485
View File
@@ -0,0 +1,485 @@
/*
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.
*/
/* double_words.c - FORTH-79 Double Number Words */
#include "include/double_words.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
/**
* @brief Convert single number to double ( n -- d )
*
* Converts a single-precision number to double-precision format.
* Result is pushed as ( dlow dhigh ) with high cell on top.
*
* @param vm Pointer to the virtual machine state
*/
void double_word_s_to_d(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
cell_t dhigh = (n < 0) ? -1 : 0;
vm_push(vm, n); // push low
vm_push(vm, dhigh); // push high
}
/* D+ ( d1 d2 -- d3 ) */
void double_word_d_plus(VM *vm) {
if (vm->dsp < 3) {
vm->error = 1;
return;
}
// Stack layout: d1low d1high d2low d2high (top)
// Pop from top: d2high, d2low, d1high, d1low
cell_t d2high = vm_pop(vm);
cell_t d2low = vm_pop(vm);
cell_t d1high = vm_pop(vm);
cell_t d1low = vm_pop(vm);
// Use unsigned arithmetic for carry detection. ucell_t (vm.h), not plain
// unsigned long -- unsigned long is only 32-bit on some bare-metal
// aarch64 cross-compile targets, silently truncating this addition and
// losing the sign-extension D. depends on (FABRIC-3.md §XII.4).
ucell_t ud1low = (ucell_t) d1low;
ucell_t ud2low = (ucell_t) d2low;
ucell_t uresult_low = ud1low + ud2low;
cell_t result_low = (cell_t) uresult_low;
cell_t carry = (uresult_low < ud1low) ? 1 : 0;
cell_t result_high = d1high + d2high + carry;
// Push result: low first, then high (so high is on top)
vm_push(vm, result_low);
vm_push(vm, result_high);
}
/* D- ( d1 d2 -- d3 ) */
void double_word_d_minus(VM *vm) {
if (vm->dsp < 3) {
vm->error = 1;
return;
}
// Stack layout: d1low d1high d2low d2high (top)
// Pop from top: d2high, d2low, d1high, d1low
cell_t d2high = vm_pop(vm);
cell_t d2low = vm_pop(vm);
cell_t d1high = vm_pop(vm);
cell_t d1low = vm_pop(vm);
// Use unsigned arithmetic for borrow detection. ucell_t, not plain
// unsigned long -- see double_word_d_plus()'s matching comment.
ucell_t ud1low = (ucell_t) d1low;
ucell_t ud2low = (ucell_t) d2low;
ucell_t uresult_low = ud1low - ud2low;
cell_t result_low = (cell_t) uresult_low;
cell_t borrow = (ud1low < ud2low) ? 1 : 0;
cell_t result_high = d1high - d2high - borrow;
// Push result: low first, then high (so high is on top)
vm_push(vm, result_low);
vm_push(vm, result_high);
}
/* DNEGATE ( d1 -- d2 ) */
void double_word_dnegate(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
// Stack layout: dlow dhigh (top)
cell_t dhigh = vm_pop(vm);
cell_t dlow = vm_pop(vm);
// Negate: ~d + 1. ucell_t, not plain unsigned long -- see
// double_word_d_plus()'s matching comment.
ucell_t new_low = ~(ucell_t) dlow + 1;
cell_t new_dhigh = ~dhigh + (new_low == 0 ? 1 : 0);
vm_push(vm, (cell_t) new_low);
vm_push(vm, new_dhigh);
}
/* DABS ( d1 -- d2 ) */
void double_word_dabs(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
// High cell is on top of stack (dsp points to top)
cell_t dhigh = vm->data_stack[vm->dsp];
if (dhigh < 0) {
double_word_dnegate(vm);
}
}
/**
* @brief Compare two double numbers
*
* @param d1h High cell of first double number
* @param d1l Low cell of first double number
* @param d2h High cell of second double number
* @param d2l Low cell of second double number
* @return int -1 if d1<d2, 0 if d1=d2, 1 if d1>d2
*/
static int d_compare(cell_t d1h, cell_t d1l, cell_t d2h, cell_t d2l) {
if (d1h < d2h) return -1;
if (d1h > d2h) return 1;
// ucell_t, not plain unsigned long -- see double_word_d_plus()'s
// matching comment (unsigned long is only 32-bit on some bare-metal
// aarch64 cross-compile targets).
ucell_t ul1 = (ucell_t) d1l;
ucell_t ul2 = (ucell_t) d2l;
return (ul1 > ul2) - (ul1 < ul2);
}
/* DMAX ( d1 d2 -- d3 ) */
void double_word_dmax(VM *vm) {
if (vm->dsp < 3) {
vm->error = 1;
return;
}
cell_t d2high = vm_pop(vm);
cell_t d2low = vm_pop(vm);
cell_t d1high = vm_pop(vm);
cell_t d1low = vm_pop(vm);
if (d_compare(d1high, d1low, d2high, d2low) >= 0) {
vm_push(vm, d1low);
vm_push(vm, d1high);
} else {
vm_push(vm, d2low);
vm_push(vm, d2high);
}
}
/* DMIN ( d1 d2 -- d3 ) */
void double_word_dmin(VM *vm) {
if (vm->dsp < 3) {
vm->error = 1;
return;
}
cell_t d2high = vm_pop(vm);
cell_t d2low = vm_pop(vm);
cell_t d1high = vm_pop(vm);
cell_t d1low = vm_pop(vm);
if (d_compare(d1high, d1low, d2high, d2low) <= 0) {
vm_push(vm, d1low);
vm_push(vm, d1high);
} else {
vm_push(vm, d2low);
vm_push(vm, d2high);
}
}
/* D< ( d1 d2 -- flag ) */
void double_word_d_less(VM *vm) {
if (vm->dsp < 3) {
vm->error = 1;
return;
}
cell_t d2high = vm_pop(vm);
cell_t d2low = vm_pop(vm);
cell_t d1high = vm_pop(vm);
cell_t d1low = vm_pop(vm);
int cmp = d_compare(d1high, d1low, d2high, d2low);
vm_push(vm, (cmp < 0) ? -1 : 0);
}
/* D= ( d1 d2 -- flag ) */
void double_word_d_equals(VM *vm) {
if (vm->dsp < 3) {
vm->error = 1;
return;
}
cell_t d2high = vm_pop(vm);
cell_t d2low = vm_pop(vm);
cell_t d1high = vm_pop(vm);
cell_t d1low = vm_pop(vm);
int cmp = d_compare(d1high, d1low, d2high, d2low);
vm_push(vm, (cmp == 0) ? -1 : 0);
}
/* 2DROP ( d -- ) */
void double_word_2drop(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
vm_pop(vm);
vm_pop(vm);
}
/* 2DUP ( d -- d d ) */
void double_word_2dup(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
// Stack: dlow dhigh (top)
cell_t dhigh = vm->data_stack[vm->dsp];
cell_t dlow = vm->data_stack[vm->dsp - 1];
vm_push(vm, dlow);
vm_push(vm, dhigh);
}
/* 2SWAP ( d1 d2 -- d2 d1 ) */
void double_word_2swap(VM *vm) {
if (vm->dsp < 3) {
vm->error = 1;
return;
}
cell_t d2high = vm_pop(vm);
cell_t d2low = vm_pop(vm);
cell_t d1high = vm_pop(vm);
cell_t d1low = vm_pop(vm);
vm_push(vm, d2low);
vm_push(vm, d2high);
vm_push(vm, d1low);
vm_push(vm, d1high);
}
/* 2OVER ( d1 d2 -- d1 d2 d1 ) */
void double_word_2over(VM *vm) {
if (vm->dsp < 3) {
vm->error = 1;
return;
}
// Stack: d1low d1high d2low d2high (top)
// Indices: dsp-3 dsp-2 dsp-1 dsp
cell_t d1low = vm->data_stack[vm->dsp - 3];
cell_t d1high = vm->data_stack[vm->dsp - 2];
vm_push(vm, d1low);
vm_push(vm, d1high);
}
/* 2ROT ( d1 d2 d3 -- d2 d3 d1 ) */
void double_word_2rot(VM *vm) {
if (vm->dsp < 5) {
vm->error = 1;
return;
}
cell_t d3high = vm_pop(vm);
cell_t d3low = vm_pop(vm);
cell_t d2high = vm_pop(vm);
cell_t d2low = vm_pop(vm);
cell_t d1high = vm_pop(vm);
cell_t d1low = vm_pop(vm);
vm_push(vm, d2low);
vm_push(vm, d2high);
vm_push(vm, d3low);
vm_push(vm, d3high);
vm_push(vm, d1low);
vm_push(vm, d1high);
}
/* 2>R ( d -- ) ( R: -- d ) */
void double_word_2to_r(VM *vm) {
if (vm->dsp < 1) { vm->error = 1; return; }
cell_t dhigh = vm_pop(vm);
cell_t dlow = vm_pop(vm);
if (vm->ecw_nesting > 0) {
/* Inside execute_colon_word: RS[rsp]=resume_ip; insert dlow,dhigh below it. */
if (vm->rsp + 2 >= STACK_SIZE) { vm->error = 1; return; }
cell_t resume_ip = vm->return_stack[vm->rsp];
vm->return_stack[vm->rsp] = dlow;
vm->return_stack[vm->rsp + 1] = dhigh;
vm->return_stack[vm->rsp + 2] = resume_ip;
vm->rsp += 2;
} else {
if (vm->rsp + 2 >= STACK_SIZE) { vm->error = 1; return; }
vm->return_stack[++vm->rsp] = dlow;
vm->return_stack[++vm->rsp] = dhigh;
}
}
/* 2R> ( -- d ) ( R: d -- ) */
void double_word_2r_from(VM *vm) {
if (vm->ecw_nesting > 0) {
/* Inside execute_colon_word: RS[rsp]=resume_ip, [rsp-1]=dhigh, [rsp-2]=dlow. */
if (vm->rsp < 2) { vm->error = 1; return; }
cell_t resume_ip = vm->return_stack[vm->rsp];
cell_t dhigh = vm->return_stack[vm->rsp - 1];
cell_t dlow = vm->return_stack[vm->rsp - 2];
vm->return_stack[vm->rsp - 2] = resume_ip;
vm->rsp -= 2;
vm_push(vm, dlow);
vm_push(vm, dhigh);
} else {
if (vm->rsp < 1) { vm->error = 1; return; }
cell_t dhigh = vm->return_stack[vm->rsp--];
cell_t dlow = vm->return_stack[vm->rsp--];
vm_push(vm, dlow);
vm_push(vm, dhigh);
}
}
/* 2R@ ( -- d ) ( R: d -- d ) */
void double_word_2r_fetch(VM *vm) {
if (vm->ecw_nesting > 0) {
/* Inside execute_colon_word: RS[rsp]=resume_ip, [rsp-1]=dhigh, [rsp-2]=dlow. */
if (vm->rsp < 2) { vm->error = 1; return; }
vm_push(vm, vm->return_stack[vm->rsp - 2]);
vm_push(vm, vm->return_stack[vm->rsp - 1]);
} else {
if (vm->rsp < 1) { vm->error = 1; return; }
vm_push(vm, vm->return_stack[vm->rsp - 1]);
vm_push(vm, vm->return_stack[vm->rsp]);
}
}
/* D0= ( d -- flag ) */
void double_word_d_zero_equals(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t dhigh = vm_pop(vm);
cell_t dlow = vm_pop(vm);
vm_push(vm, (dhigh == 0 && dlow == 0) ? -1 : 0);
}
/* D0< ( d -- flag ) */
void double_word_d_zero_less(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t dhigh = vm_pop(vm);
vm_pop(vm); // dlow (unused, but must pop)
vm_push(vm, (dhigh < 0) ? -1 : 0);
}
/* D2* ( d1 -- d2 ) */
void double_word_d_two_star(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t dhigh = vm_pop(vm);
cell_t dlow = vm_pop(vm);
// Left shift: new_low = dlow << 1, new_high = (dhigh << 1) | (carry from dlow)
unsigned long long udlow = (unsigned long long)(uint64_t) dlow;
cell_t new_dlow = (cell_t)(udlow << 1);
cell_t new_dhigh = (dhigh << 1) | ((udlow >> 63) & 1);
vm_push(vm, new_dlow);
vm_push(vm, new_dhigh);
}
/* D2/ ( d1 -- d2 ) */
void double_word_d_two_slash(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t dhigh = vm_pop(vm);
cell_t dlow = vm_pop(vm);
// Arithmetic right shift: preserve sign in high cell
cell_t new_dhigh = dhigh >> 1;
unsigned long long udlow = (unsigned long long)(uint64_t) dlow;
cell_t new_dlow = (cell_t)((udlow >> 1) | ((dhigh & 1) ? (1ULL << 63) : 0));
vm_push(vm, new_dlow);
vm_push(vm, new_dhigh);
}
/**
* @brief Register all double number words
*
* Registers all double-precision number operations with the virtual machine.
*
* @param vm Pointer to the virtual machine state
*
* @note This function must be called during VM initialization.
*/
void register_double_words(VM *vm) {
register_word(vm, "S>D", double_word_s_to_d);
register_word(vm, "D+", double_word_d_plus);
register_word(vm, "D-", double_word_d_minus);
register_word(vm, "DNEGATE", double_word_dnegate);
register_word(vm, "DABS", double_word_dabs);
register_word(vm, "DMAX", double_word_dmax);
register_word(vm, "DMIN", double_word_dmin);
register_word(vm, "D<", double_word_d_less);
register_word(vm, "D=", double_word_d_equals);
register_word(vm, "2DROP", double_word_2drop);
register_word(vm, "2DUP", double_word_2dup);
register_word(vm, "2SWAP", double_word_2swap);
register_word(vm, "2OVER", double_word_2over);
register_word(vm, "2ROT", double_word_2rot);
register_word(vm, "2>R", double_word_2to_r);
register_word(vm, "2R>", double_word_2r_from);
register_word(vm, "2R@", double_word_2r_fetch);
register_word(vm, "D0=", double_word_d_zero_equals);
register_word(vm, "D0<", double_word_d_zero_less);
register_word(vm, "D2*", double_word_d_two_star);
register_word(vm, "D2/", double_word_d_two_slash);
}
v3/src/word_source/editor_words.c
+344
View File
@@ -0,0 +1,344 @@
/*
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/editor_words.h" /* register_editor_words prototype */
#include "include/block_words.h" /* mark_buffer_dirty(), MAX_BLOCKS, BLOCK_SIZE */
#include "../../include/vm.h" /* VM, vm_load_cell, vm_store_cell, vm_addr_ok, vm_ptr */
#include "../../include/word_registry.h" /* register_word */
#include "../../include/log.h" /* log_message */
#include <stdio.h> /* fputs, fflush, puts, printf */
#include <string.h> /* memset, memcpy, strlen, isdigit, isspace */
#include <ctype.h> /* isdigit, isspace */
/* -------- helpers -------- */
/** @brief Get current screen number from VM
* @param vm Pointer to VM instance
* @return Current screen number
*/
static inline cell_t current_scr(VM *vm) {
return vm_load_cell(vm, vm->scr_addr);
}
/** @brief Get pointer to specific line in a screen
* @param vm Pointer to VM instance
* @param scr Screen number (1-based)
* @param line Line number (0-15)
* @param out Output parameter for line pointer
* @return 1 if successful, 0 if parameters invalid
*/
static int line_ptr(VM *vm, cell_t scr, cell_t line, unsigned char **out) {
if (!vm || !out) return 0;
if (scr < 1 || scr >= (cell_t) MAX_BLOCKS) return 0;
if (line < 0 || line > 15) return 0;
/* Use block subsystem to get block buffer */
extern uint8_t *blk_get_buffer(uint32_t block_num, int writable);
extern int blk_is_valid(uint32_t block_num);
if (!blk_is_valid((uint32_t) scr)) return 0;
uint8_t *block = blk_get_buffer((uint32_t) scr, 1); /* writable for editing */
if (!block) return 0;
*out = block + (line * 64);
return 1;
}
/** @brief Print 64-character line with character filtering
* @param p Pointer to 64-byte line buffer
*/
static void print_line_64(const unsigned char *p) {
#ifdef STARFORTH_ANSI
/* No cursor moves unless asked; just render content cleanly. */
#endif
for (int i = 0; i < 64; ++i) {
unsigned char c = p[i];
if (c == 0) { putchar(' '); } else if (c >= 32 && c <= 126) { putchar((int) c); } else {
putchar('.');
}
}
putchar('\n');
}
/* -------- words -------- */
/* L ( u -- ) : print line u of current SCR (0..15). Errors on empty/range/invalid SCR. */
static void editor_word_l(VM *vm) {
if (!vm) return;
if (vm->dsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "L: stack underflow (needs line# 0..15)");
return;
}
cell_t line = vm_pop(vm);
if (line < 0 || line > 15) {
vm->error = 1;
log_message(LOG_ERROR, "L: line out of range (0..15)");
return;
}
cell_t scr = current_scr(vm);
if (scr < 1 || scr >= (cell_t) MAX_BLOCKS) {
vm->error = 1;
log_message(LOG_ERROR, "L: SCR out of range (SCR=%ld)", (long) scr);
return;
}
unsigned char *lp = NULL;
if (!line_ptr(vm, scr, line, &lp)) {
vm->error = 1;
log_message(LOG_ERROR, "L: address invalid for SCR=%ld line=%ld", (long) scr, (long) line);
return;
}
print_line_64(lp);
}
/* S ( c-addr len u -- ) : set line u from buffer (pads with spaces to 64, truncates if longer). */
static void editor_word_s(VM *vm) {
if (!vm) return;
/* Pop in the order that lets us validate line range before address checks (useful in tests). */
if (vm->dsp < 2) {
vm->error = 1;
log_message(LOG_ERROR, "S: stack underflow (needs c-addr len line#)");
return;
}
cell_t line = vm_pop(vm);
if (line < 0 || line > 15) {
vm->error = 1;
log_message(LOG_ERROR, "S: line out of range (0..15)");
/* Drain remaining args to keep stack sane */
(void) vm_pop(vm);
(void) vm_pop(vm);
return;
}
cell_t len = vm_pop(vm);
cell_t addr = vm_pop(vm);
if (len < 0) len = 0; /* defensive: negative length treated as 0 */
cell_t scr = current_scr(vm);
if (scr < 1 || scr >= (cell_t) MAX_BLOCKS) {
vm->error = 1;
log_message(LOG_ERROR, "S: SCR out of range (SCR=%ld)", (long) scr);
return;
}
unsigned char *dst = NULL;
if (!line_ptr(vm, scr, line, &dst)) {
vm->error = 1;
log_message(LOG_ERROR, "S: destination address invalid");
return;
}
/* Source pointer */
if (!vm_addr_ok(vm, (vaddr_t) addr, (size_t) len)) {
vm->error = 1;
log_message(LOG_ERROR, "S: source range invalid (addr=%ld len=%ld)",
(long) addr, (long) len);
return;
}
const unsigned char *src = (const unsigned char *) vm_ptr(vm, (vaddr_t) addr);
/* Write: pad spaces, then copy up to 64 */
memset(dst, ' ', 64);
size_t n = (len > 64) ? 64 : (size_t) len;
if (n > 0) memcpy(dst, src, n);
mark_buffer_dirty(vm);
}
/* SHOW ( -- ) : print the whole 16x64 screen with simple line numbers. */
static void editor_word_show(VM *vm) {
if (!vm) return;
cell_t scr = current_scr(vm);
if (scr < 1 || scr >= (cell_t) MAX_BLOCKS) {
vm->error = 1;
log_message(LOG_ERROR, "SHOW: SCR out of range (SCR=%ld)", (long) scr);
return;
}
#ifdef STARFORTH_ANSI
/* Clear + home (optional; compile-time opt-in) */
fputs("\x1b[2J\x1b[H", stdout);
printf("\x1b[1mScreen %ld\x1b[0m:\n", (long) scr);
#else
printf("Screen %ld:\n", (long) scr);
#endif
for (cell_t line = 0; line < 16; ++line) {
unsigned char *lp = NULL;
if (!line_ptr(vm, scr, line, &lp)) {
vm->error = 1;
return;
}
#ifdef STARFORTH_ANSI
printf("\x1b[90m%2ld:\x1b[0m ", (long) line);
#else
printf("%2ld: ", (long) line);
#endif
print_line_64(lp);
}
}
/* EDIT ( u -- ) : tiny line-editor shell (stdin/stdout). No raw mode, no curses. */
/* EDIT ( u -- ) : tiny line-editor shell (stdin/stdout). No raw mode, no curses. */
static void editor_word_edit(VM *vm) {
if (!vm) return;
if (vm->dsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "EDIT: stack underflow (needs block#)");
return;
}
cell_t blk = vm_pop(vm);
if (blk < 1 || blk >= (cell_t) MAX_BLOCKS) {
vm->error = 1;
log_message(LOG_ERROR, "EDIT: block out of range");
return;
}
vm_store_cell(vm, vm->scr_addr, blk);
editor_word_show(vm);
if (vm->error) return;
char buf[1024];
for (;;) {
printf("SCR %ld> ", (long) vm_load_cell(vm, vm->scr_addr));
fflush(stdout);
if (!fgets(buf, sizeof buf, stdin)) break;
/* Trim trailing newline */
size_t L = strlen(buf);
if (L && buf[L - 1] == '\n') buf[L - 1] = '\0';
if (buf[0] == 'q' || buf[0] == 'Q') break;
else if (buf[0] == 'h' || buf[0] == 'H') {
puts("Commands: p=print, l <n>=line, s <n> <text>=set, n=next, b=prev, w=write, q=quit");
} else if (buf[0] == 'p' || buf[0] == 'P') {
editor_word_show(vm);
} else if (buf[0] == 'l' || buf[0] == 'L') {
long ln = -1;
/* Simple number parsing to avoid sscanf */
const char *p = buf + 1;
while (*p == ' ' || *p == '\t') p++;
if (isdigit(*p)) {
ln = 0;
while (isdigit(*p)) {
ln = ln * 10 + (*p - '0');
p++;
}
vm_push(vm, (cell_t) ln);
editor_word_l(vm);
} else {
puts("usage: l <0..15>");
}
} else if (buf[0] == 's' || buf[0] == 'S') {
long ln = -1;
const char *p = buf + 1;
while (*p && isspace((unsigned char) *p)) ++p;
/* Parse number manually */
if (isdigit(*p)) {
ln = 0;
while (isdigit(*p)) {
ln = ln * 10 + (*p - '0');
p++;
}
/* Move past any remaining spaces */
while (*p && isspace((unsigned char) *p)) ++p;
/* p is now the text to write */
size_t tlen = strlen(p);
cell_t scr = vm_load_cell(vm, vm->scr_addr);
unsigned char *dst = NULL;
if (ln < 0 || ln > 15 || scr < 1 || scr >= (cell_t) MAX_BLOCKS ||
!line_ptr(vm, scr, (cell_t) ln, &dst)) {
puts("error: bad SCR/line");
} else {
memset(dst, ' ', 64);
size_t n = (tlen > 64) ? 64 : tlen;
if (n) memcpy(dst, p, n);
/* ✅ Use helpers declared in block_words.h (no implicit decl) */
mark_buffer_dirty(vm);
puts("ok");
}
} else {
puts("usage: s <0..15> <text>");
}
} else if (buf[0] == 'n' || buf[0] == 'N') {
cell_t s = vm_load_cell(vm, vm->scr_addr);
if (s + 1 < (cell_t) MAX_BLOCKS) vm_store_cell(vm, vm->scr_addr, s + 1);
editor_word_show(vm);
} else if (buf[0] == 'b' || buf[0] == 'B') {
cell_t s = vm_load_cell(vm, vm->scr_addr);
if (s - 1 >= 1) vm_store_cell(vm, vm->scr_addr, s - 1);
editor_word_show(vm);
} else if (buf[0] == 'w' || buf[0] == 'W') {
/* ✅ No more implicit decls: use helpers */
mark_buffer_dirty(vm);
save_all_buffers(vm);
puts("saved");
} else {
puts("h for help");
}
if (vm->error) {
puts("error");
vm->error = 0; /* keep shell alive */
}
}
}
/* -------- registration -------- */
void register_editor_words(VM *vm) {
if (!vm) return;
register_word(vm, "L", editor_word_l); /* non-79 */
register_word(vm, "S", editor_word_s); /* non-79 */
register_word(vm, "SHOW", editor_word_show); /* non-79 */
register_word(vm, "EDIT", editor_word_edit); /* non-79 */
}
v3/src/word_source/format_words.c
+480
View File
@@ -0,0 +1,480 @@
/*
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/format_words.h"
#include "../../include/word_registry.h"
#include "../../include/log.h"
#include "../../include/vm.h"
#include <stdint.h>
#include <limits.h>
#include <string.h>
#include <stdio.h>
/* Pictured-number hold buffer lives in each VM's own memory (hold_addr / hold_pos).
* These macros provide the same interface as the old static globals but are per-VM,
* so child VMs never alias Hera's buffer. */
#define PN_CAP 64
#define PN_BUF(vm) ((unsigned char *)((vm)->memory + (vm)->hold_addr))
#define CELL_BITS ((int)(sizeof(cell_t) * CHAR_BIT))
#define CHUNK_BITS 16
#define CHUNK_MASK ((uint64_t)(UINT64_C(1) << CHUNK_BITS) - 1)
/** @brief Returns current numeric conversion base, defaulting to 10 if invalid */
static unsigned current_base(VM *vm) {
unsigned b = (unsigned) vm->base;
return (b < 2 || b > 36) ? 10u : b;
}
/** @brief Converts value 0-35 to character '0'-'9' or 'A'-'Z' */
static char digit_for(unsigned v) {
return (v < 10) ? (char) ('0' + v) : (char) ('A' + (v - 10));
}
/* Divide unsigned double-cell (dhigh:dlow) by base (2..36), portable C99 */
/** @brief Divides unsigned double-cell number by base using portable C99 code */
static void div_ud_by_base(cell_t dhigh_in, cell_t dlow_in, unsigned base,
cell_t *qhigh_out, cell_t *qlow_out, unsigned *rem_out) {
uint64_t base_ul = (uint64_t) base;
uint64_t r = 0;
uint64_t qh = 0, ql = 0;
/* High word */
{
uint64_t hi = (uint64_t)(ucell_t) dhigh_in;
int parts = CELL_BITS / CHUNK_BITS;
for (int i = parts - 1; i >= 0; --i) {
uint64_t chunk = (hi >> (i * CHUNK_BITS)) & CHUNK_MASK;
uint64_t val = (r << CHUNK_BITS) + chunk;
uint64_t qchunk = val / base_ul;
r = val % base_ul;
qh = (qh << CHUNK_BITS) | (qchunk & CHUNK_MASK);
}
}
/* Low word */
{
uint64_t lo = (uint64_t)(ucell_t) dlow_in;
int parts = CELL_BITS / CHUNK_BITS;
for (int i = parts - 1; i >= 0; --i) {
uint64_t chunk = (lo >> (i * CHUNK_BITS)) & CHUNK_MASK;
uint64_t val = (r << CHUNK_BITS) + chunk;
uint64_t qchunk = val / base_ul;
r = val % base_ul;
ql = (ql << CHUNK_BITS) | (qchunk & CHUNK_MASK);
}
}
*qhigh_out = (cell_t) qh;
*qlow_out = (cell_t) ql;
*rem_out = (unsigned) r;
}
/* Render one cell in current base (no printf %x/%o so input==output base) */
/** @brief Prints number with optional width field and sign handling */
static void print_number_formatted(VM *vm, cell_t n, int width, int is_unsigned) {
char buf[80];
int i = 0;
unsigned base = current_base(vm);
if (!is_unsigned && n == 0) {
buf[i++] = '0';
} else if (is_unsigned) {
uint64_t u = (uint64_t)(ucell_t) n;
if (u == 0) buf[i++] = '0';
while (u != 0) {
uint64_t rem = u % (uint64_t) base;
u /= (uint64_t) base;
buf[i++] = digit_for((unsigned) rem);
}
} else {
int neg = (n < 0);
uint64_t u = (uint64_t)(ucell_t) n;
if (neg) u = (uint64_t) 0 - u;
if (u == 0) buf[i++] = '0';
while (u != 0) {
uint64_t rem = u % (uint64_t) base;
u /= (uint64_t) base;
buf[i++] = digit_for((unsigned) rem);
}
if (neg) buf[i++] = '-';
}
int len = i;
if (width > 0 && len < width) for (int s = 0; s < width - len; ++s) putchar(' ');
while (i--) putchar(buf[i]);
}
/* ===== Words ===== */
/* BASE ( -- addr ) — returns VM address (offset) of the BASE variable */
void format_word_base(VM *vm) {
if (!vm) { return; }
/* vm->base_addr is a VM address (offset into vm->memory), not a host pointer */
vm_push(vm, CELL(vm->base_addr));
}
/* DECIMAL ( -- ) — set BASE=10 */
void format_word_decimal(VM *vm) {
if (!vm) { return; }
vm_set_base(vm, 10);
}
/* HEX ( -- ) — set BASE=16 */
void format_word_hex(VM *vm) {
if (!vm) { return; }
vm_set_base(vm, 16);
}
/* OCTAL ( -- ) — set BASE=8 */
void format_word_octal(VM *vm) {
if (!vm) { return; }
vm_set_base(vm, 8);
}
/* <# ( -- ) */
void format_word_begin_conversion(VM *vm) {
vm->hold_pos = 0;
memset(PN_BUF(vm), 0, PN_CAP);
}
/* HOLD ( c -- ) */
void format_word_hold(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
log_message(LOG_ERROR, "HOLD: data stack underflow");
return;
}
cell_t c = vm_pop(vm);
/* Must be a single byte 0..255 */
if (c < 0 || c > 255) {
vm->error = 1;
log_message(LOG_ERROR, "HOLD: byte out of range (%ld)", (long) c);
return;
}
/* keep 1 byte of headroom (null safety) */
if (vm->hold_pos >= PN_CAP - 1) {
vm->error = 1;
log_message(LOG_ERROR, "HOLD: conversion buffer full (pos=%d cap=%d)", vm->hold_pos, PN_CAP);
return;
}
/* Prepend the byte */
memmove(&PN_BUF(vm)[1], &PN_BUF(vm)[0], (size_t) vm->hold_pos);
PN_BUF(vm)[0] = (unsigned char) c;
vm->hold_pos++;
}
/* SIGN ( n -- ) */
void format_word_sign(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
if (n < 0) {
vm_push(vm, '-');
format_word_hold(vm);
}
}
/* # ( ud1 | n -- ud2 )
Tolerant form:
- If only one cell is present, treat it as a signed single and convert its magnitude.
- SIGN (if used) is responsible for inserting '-' afterwards. */
void format_word_hash(VM *vm) {
cell_t dlow, dhigh;
/* If we don't have a full double, but have one cell, promote it. */
if (vm->dsp < 1) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
unsigned long u = (n < 0) ? (unsigned long) (-(cell_t) n) : (unsigned long) n;
dhigh = 0;
dlow = (cell_t) u;
} else {
/* Normal path: consume unsigned double (dlow dhigh) */
dlow = vm_pop(vm);
dhigh = vm_pop(vm);
}
unsigned base = current_base(vm);
cell_t qh, ql;
unsigned rem;
div_ud_by_base(dhigh, dlow, base, &qh, &ql, &rem);
/* Emit rightmost digit via HOLD */
vm_push(vm, (cell_t) digit_for(rem));
format_word_hold(vm);
if (vm->error) return;
/* Push quotient back as (dhigh dlow) so #S can loop */
vm_push(vm, qh);
vm_push(vm, ql);
}
/* #S ( ud | n -- 0 0 ) — tolerant:
If only one cell is present, treat it as a signed single and convert its magnitude.
SIGN (if used) is responsible for inserting '-' later. */
void format_word_hash_s(VM *vm) {
/* If we don't have a full double, but have one cell, promote it. */
if (vm->dsp < 1) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
/* Promote single to (dhigh=0, dlow=abs(n)) so # works on magnitude */
cell_t n = vm_pop(vm);
unsigned long u = (n < 0) ? (unsigned long) (-(cell_t) n) : (unsigned long) n;
/* Stack order for format_word_hash: top must be dlow, under it dhigh */
vm_push(vm, (cell_t) 0); /* dhigh */
vm_push(vm, (cell_t) u); /* dlow */
}
for (;;) {
/* Always convert at least once so 0 produces "0". */
format_word_hash(vm);
if (vm->error) return;
/* Peek the quotient (dhigh dlow) that '#' just pushed back */
cell_t dlow = vm->data_stack[vm->dsp];
cell_t dhigh = vm->data_stack[vm->dsp - 1];
if (dhigh == 0 && dlow == 0) break;
}
}
/* #> ( [ud] -- addr u ) — tolerant: pops ud iff present, else just returns buffer */
void format_word_end_conversion(VM *vm) {
/* If there’s at least a double on the stack, drop it (dlow dhigh). */
if (vm->dsp >= 1) {
(void) vm_pop(vm);
(void) vm_pop(vm);
}
/* Push VM address (offset) of the hold buffer and its fill count */
vm_push(vm, CELL(vm->hold_addr));
vm_push(vm, (cell_t) vm->hold_pos);
}
/* . ( n -- ) */
void format_word_dot(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t n = vm_pop(vm);
print_number_formatted(vm, n, 0, 0);
putchar(' ');
}
/* .R ( n width -- ) */
void format_word_dot_r(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t width = vm_pop(vm);
cell_t n = vm_pop(vm);
print_number_formatted(vm, n, (int) width, 0);
putchar(' ');
}
/* U. ( u -- ) */
void format_word_u_dot(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
cell_t u = vm_pop(vm);
print_number_formatted(vm, u, 0, 1);
putchar(' ');
}
/* U.R ( u width -- ) */
void format_word_u_dot_r(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t width = vm_pop(vm);
cell_t u = vm_pop(vm);
print_number_formatted(vm, u, (int) width, 1);
putchar(' ');
}
/* D. ( d -- ) */
void format_word_d_dot(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t dlow = vm_pop(vm);
cell_t dhigh = vm_pop(vm);
if ((dhigh == 0) || (dhigh == -1 && dlow < 0)) {
print_number_formatted(vm, dlow, 0, 0);
} else {
fputs("DOUBLE-OVERFLOW", stdout);
}
putchar(' ');
}
/* D.R ( d width -- ) */
void format_word_d_dot_r(VM *vm) {
if (vm->dsp < 2) {
vm->error = 1;
return;
}
cell_t width = vm_pop(vm);
cell_t dlow = vm_pop(vm);
cell_t dhigh = vm_pop(vm);
if ((dhigh == 0) || (dhigh == -1 && dlow < 0)) {
print_number_formatted(vm, dlow, (int) width, 0);
} else {
int len = (int) strlen("DOUBLE-OVERFLOW");
for (int i = 0; i < ((int) width > len ? (int) width - len : 0); ++i) putchar(' ');
fputs("DOUBLE-OVERFLOW", stdout);
}
putchar(' ');
}
/* .S ( -- ) */
void format_word_dot_s(VM *vm) {
printf("<%d> ", vm->dsp + 1);
for (int i = 0; i <= vm->dsp; i++) {
print_number_formatted(vm, vm->data_stack[i], 0, 0);
putchar(' ');
}
putchar('\n');
}
/* ? ( addr -- ) */
void format_word_question(VM *vm) {
if (vm->dsp < 0) {
vm->error = 1;
return;
}
vaddr_t addr = VM_ADDR(vm_pop(vm));
if (!vm_addr_ok(vm, addr, sizeof(cell_t))) {
vm->error = 1;
return;
}
print_number_formatted(vm, vm_load_cell(vm, addr), 0, 0);
putchar(' ');
}
/* DUMP ( addr u -- ) */
void format_word_dump(VM *vm) {
if (vm->dsp < 1) {
vm->error = 1;
return;
}
cell_t u = vm_pop(vm);
vaddr_t addr = VM_ADDR(vm_pop(vm));
if (u < 0) {
vm->error = 1;
return;
}
size_t n = (size_t) u;
if (!vm_addr_ok(vm, addr, n)) {
vm->error = 1;
return;
}
const uint8_t *ptr = vm_ptr(vm, addr);
int addr_width = (int) (sizeof(vaddr_t) * 2);
for (size_t i = 0; i < n; i += 16) {
unsigned long long a = (unsigned long long) (addr + i);
printf("%0*llX: ", addr_width, a);
size_t j = 0;
for (; j < 16 && i + j < n; j++) printf("%02X ", ptr[i + j]);
for (; j < 16; j++) printf(" ");
fputs(" |", stdout);
for (j = 0; j < 16 && i + j < n; j++) {
char c = (char) ptr[i + j];
putchar((c >= 32 && c <= 126) ? c : '.');
}
fputs("|\n", stdout);
}
}
/* Registration */
/**
* @brief Registers all formatting and numeric conversion words with the VM.
*
* This function registers the standard FORTH formatting words including:
* - Number output words (., .R, U., U.R, D., D.R, .S, ?)
* - Picture number formatting (<#, #, #S, #>, HOLD, SIGN)
* - Base conversion (BASE, DECIMAL, HEX, OCTAL)
* - Memory dump (DUMP)
*
* @param vm Pointer to the virtual machine instance
*/
void register_format_words(VM *vm) {
register_word(vm, ".", format_word_dot);
register_word(vm, ".R", format_word_dot_r);
register_word(vm, "U.", format_word_u_dot);
register_word(vm, "U.R", format_word_u_dot_r);
register_word(vm, "D.", format_word_d_dot);
register_word(vm, "D.R", format_word_d_dot_r);
register_word(vm, ".S", format_word_dot_s);
register_word(vm, "?", format_word_question);
register_word(vm, "DUMP", format_word_dump);
register_word(vm, "<#", format_word_begin_conversion);
register_word(vm, "#", format_word_hash);
register_word(vm, "#S", format_word_hash_s);
register_word(vm, "#>", format_word_end_conversion);
register_word(vm, "HOLD", format_word_hold);
register_word(vm, "SIGN", format_word_sign);
register_word(vm, "BASE", format_word_base);
register_word(vm, "DECIMAL", format_word_decimal);
register_word(vm, "HEX", format_word_hex);
register_word(vm, "OCTAL", format_word_octal);
}
v3/src/word_source/framebuffer_words.c
+65
View File
@@ -0,0 +1,65 @@
/*
StarForth — Steady-State Virtual Machine Runtime
Copyright (c) 2023–2025 Robert A. James
All rights reserved.
Licensed under the StarForth License, Version 1.0
*/
/* framebuffer_words.c — raw framebuffer hardware-boundary FORTH words
* (FABRIC-0.md item 4.3.3). Kernel-only; no-op on hosted builds. */
#include "include/framebuffer_words.h"
#include "../../include/log.h"
#include "../../include/word_registry.h"
#ifdef __STARKERNEL__
#include "starkernel/framebuffer.h"
#endif
/* PLOT ( x y color -- ) : raw raster pixel write, top-left origin, Y-down.
* No Cartesian awareness -- that is capsules/fabric.4th's job. */
static void fbw_plot(VM *vm)
{
if (vm->dsp < 2) {
log_message(LOG_ERROR, "PLOT: Stack underflow");
vm->error = 1;
return;
}
cell_t color = vm_pop(vm);
cell_t y = vm_pop(vm);
cell_t x = vm_pop(vm);
#ifdef __STARKERNEL__
fb_put_pixel((uint32_t)x, (uint32_t)y, (uint32_t)color);
#else
(void)x; (void)y; (void)color;
#endif
}
/* FB-WIDTH ( -- n ) */
static void fbw_width(VM *vm)
{
#ifdef __STARKERNEL__
vm_push(vm, (cell_t)fb_width());
#else
vm_push(vm, 0);
#endif
}
/* FB-HEIGHT ( -- n ) */
static void fbw_height(VM *vm)
{
#ifdef __STARKERNEL__
vm_push(vm, (cell_t)fb_height());
#else
vm_push(vm, 0);
#endif
}
void register_framebuffer_words(VM *vm)
{
register_word(vm, "PLOT", fbw_plot);
register_word(vm, "FB-WIDTH", fbw_width);
register_word(vm, "FB-HEIGHT", fbw_height);
}
v3/src/word_source/include/README.md
+11
View File
@@ -0,0 +1,11 @@
# src/word_source/include/
Public headers for `src/word_source/`, one per `.c` file there (see
`src/word_source/README.md` for the category breakdown), plus
`control_words.h` and `mama_forth_words.h`:
- `control_words.h` — declarations for `control_words.c`'s `IF`/`THEN`/
`ELSE`/`BEGIN`/`DO`/`LOOP` family.
- `mama_forth_words.h` — declares the Mama VM word bindings implemented in
`src/starkernel/capsule/mama_forth_words.c` (kernel-only; the header
lives here for consistency with the rest of the word-category headers).
v3/src/word_source/include/acl_words.h
+8
View File
@@ -0,0 +1,8 @@
#pragma once
#include "vm.h"
/* Register all ACL C primitive words into the VM dictionary */
void register_acl_words(VM *vm);
/* Direct C entry point for birth inheritance (no stack manipulation needed) */
void acl_inherit_entry(DictEntry *src, DictEntry *dst);
v3/src/word_source/include/arithmetic_words.h
+90
View File
@@ -0,0 +1,90 @@
/*
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.
*/
#ifndef ARITHMETIC_WORDS_H
#define ARITHMETIC_WORDS_H
#include "vm.h"
/* FORTH-79 Arithmetic Words:
* + ( n1 n2 -- n3 ) Add n1 and n2
* - ( n1 n2 -- n3 ) Subtract n2 from n1
* * ( n1 n2 -- n3 ) Multiply n1 and n2
* / ( n1 n2 -- n3 ) Divide n1 by n2
* MOD ( n1 n2 -- n3 ) Remainder of n1/n2
* /MOD ( n1 n2 -- n3 n4 ) n3=remainder, n4=quotient of n1/n2
* NEGATE ( n1 -- n2 ) Negate n1
* ABS ( n1 -- n2 ) Absolute value of n1
* MIN ( n1 n2 -- n3 ) Minimum of n1 and n2
* MAX ( n1 n2 -- n3 ) Maximum of n1 and n2
* 1+ ( n1 -- n2 ) Add 1 to n1
* 1- ( n1 -- n2 ) Subtract 1 from n1
* 2* ( n1 -- n2 ) Multiply n1 by 2 (left shift)
* 2/ ( n1 -- n2 ) Divide n1 by 2 (right shift)
* STAR-SLASH ( n1 n2 n3 -- n4 ) Multiply n1*n2, divide by n3
*/
/**
* @brief Registers all FORTH-79 arithmetic words with the virtual machine
*
* Registers the following words:
* - + (add)
* - - (subtract)
* - * (multiply)
* - / (divide)
* - MOD (modulo)
* - /MOD (divide with remainder)
* - NEGATE
* - ABS (absolute)
* - MIN
* - MAX
* - 1+ (increment)
* - 1- (decrement)
* - 2* (multiply by 2)
* - 2/ (divide by 2)
* - STAR-SLASH (multiply then divide)
*
* @param vm Pointer to the Forth virtual machine instance
*/
void register_arithmetic_words(VM * vm);
#endif /* ARITHMETIC_WORDS_H */
v3/src/word_source/include/block_words.h
+196
View File
@@ -0,0 +1,196 @@
/*
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.
*/
/**
* @file block_words.h
* @brief FORTH-79 Block and Buffer System Implementation
*
* This file implements the standard FORTH-79 block and buffer words:
* @li BLOCK ( u -- addr ) Get block buffer address
* @li BUFFER ( u -- addr ) Get empty buffer for block
* @li UPDATE ( -- ) Mark current block as modified
* @li SAVE-BUFFERS ( -- ) Save all modified blocks
* @li EMPTY-BUFFERS ( -- ) Mark all buffers as empty
* @li FLUSH ( -- ) Save buffers and empty them
* @li LIST ( u -- ) List block contents
* @li LOAD ( u -- ) Load and interpret block
* @li SCR ( -- addr ) Variable: screen/block being listed
* @li THRU ( u1 u2 -- ) Load blocks from u1 to u2
* @li --> or → ( -- ) Continue to next block
*/
#ifndef BLOCK_WORDS_H
#define BLOCK_WORDS_H
#include "vm.h"
/** @name Block System Configuration
* @{
*/
/** @brief Size of each block in bytes (1KB) */
#define BLOCK_SIZE 1024
/** @brief Maximum number of blocks (1024 blocks from 1MB memory) */
#define MAX_BLOCKS (VM_MEMORY_SIZE / BLOCK_SIZE)
/** @brief Number of block buffers in memory */
#define BUFFER_COUNT 4
/** @} */
/**
* @brief Block buffer types for different storage mechanisms
*/
typedef enum {
BUFFER_TYPE_MEMORY, /**< Direct memory access (current implementation) */
BUFFER_TYPE_HARDWARE, /**< Future: Hardware register blocks */
BUFFER_TYPE_STORAGE, /**< Future: Persistent storage blocks */
BUFFER_TYPE_NETWORK /**< Future: Network packet buffers */
} buffer_type_t;
/**
* @brief Block buffer structure maintaining buffer state
*/
typedef struct {
unsigned char data[BLOCK_SIZE]; /**< Block content buffer */
int block_number; /**< Currently loaded block number (-1 = empty) */
int dirty; /**< Modified flag for write-back */
int accessed; /**< LRU counter for buffer management */
buffer_type_t type; /**< Buffer type for storage mechanism */
uintptr_t hw_address; /**< Future: Hardware backing address */
} BlockBuffer;
/**
* @brief Registers all block and buffer words with the virtual machine
* @param vm Pointer to the Forth virtual machine instance
*/
void register_block_words(VM * vm);
/**
* @brief Initializes the block system
* @param vm Pointer to the Forth virtual machine instance
*/
void init_block_system(VM * vm);
/*
* @brief Gets a buffer containing the specified block
* @param vm Pointer to the Forth virtual machine instance
* @param block_num Block number to retrieve
* @return Pointer to the block buffer data
*/
unsigned char *get_block_buffer(VM *vm, int block_num);
/*
* @brief Gets an empty buffer for the specified block
* @param vm Pointer to the Forth virtual machine instance
* @param block_num Block number to allocate
* @return Pointer to the empty buffer data
*/
unsigned char *get_empty_buffer(VM *vm, int block_num);
/**
* @brief Marks the current buffer as modified
* @param vm Pointer to the Forth virtual machine instance
*/
void mark_buffer_dirty(VM * vm);
/*
* @brief Saves all modified buffers to storage
* @param vm Pointer to the Forth virtual machine instance
*/
void save_all_buffers(VM * vm);
/**
* @brief Sync every dirty VM block-window slot to the C-layer block cache,
* then flush the whole block subsystem to physical media --
* the complete SAVE-BUFFERS implementation (unlike
* save_all_buffers() above, which only calls blk_flush() and so
* misses any BUFFER-modified-but-not-yet-UPDATE'd content still
* sitting only in vm->memory's window). Cheap to call when nothing
* is dirty -- every check inside is a small fixed-size scan, no
* I/O happens unless something actually needs writing. Safe to
* call from outside word dispatch (e.g. a periodic idle-tick
* auto-flush); vm must be non-NULL.
* @param vm Pointer to the Forth virtual machine instance
*/
void blk_vm_flush_all(VM * vm);
/*
* @brief Marks all buffers as empty
* @param vm Pointer to the Forth virtual machine instance
*/
void empty_all_buffers(VM * vm);
/**
* @brief Discards vm->blk_vm_lbn[]/cbuf[]/dirty[] if the device chain has
* changed since last validated (see this function's own doc comment in
* block_words.c for why). Exposed (Phase 8 v3, 2026-09-23) so callers
* outside this file that read vm->blk_vm_lbn[] directly (MOVE/CMOVE's
* cross-device block-copy check, memory_words.c/string_words.c) go through
* the same invalidation contract blk_vm_find() already uses internally,
* rather than a second, divergent copy of this logic.
* @param vm Pointer to the Forth virtual machine instance
*/
void blk_vm_check_epoch(VM *vm);
/**
* @brief Does `addr` fall inside the block I/O window? Pure address
* arithmetic against the window's fixed compile-time base/size -- no VM
* state needed. Exposed (Phase 8 v3, 2026-09-23) for MOVE/CMOVE/CMOVE>'s
* cross-device block-copy check.
* @param addr VM offset to test
* @return slot index (0..BLK_VM_SLOTS-1) if inside the window, -1 otherwise
*/
int blk_vm_slot_for_addr(vaddr_t addr);
/**
* @brief True if addr1/addr2 are both block-window addresses currently
* loaded from two different physical devices (Phase 8 v3, 2026-09-23) --
* the check MOVE/CMOVE/CMOVE> call before copying to refuse a same-VM,
* cross-device raw block copy. See this function's own doc comment in
* block_words.c for exactly what is and isn't flagged.
* @param vm VM performing the copy
* @param addr1 first VM offset (source or destination, order doesn't matter)
* @param addr2 second VM offset
* @return 1 if this copy should be refused, 0 otherwise
*/
int blk_vm_is_cross_device_copy(VM *vm, vaddr_t addr1, vaddr_t addr2);
#endif /* BLOCK_WORDS_H */
v3/src/word_source/include/control_words.h
+127
View File
@@ -0,0 +1,127 @@
/*
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.
*/
#ifndef CONTROL_WORDS_H
#define CONTROL_WORDS_H
#include "vm.h"
/**
* @defgroup control_words FORTH-79 Control Flow Words
* @{
* @brief Standard FORTH-79 control flow words implementation
*
* @def IF ( flag -- )
* Conditional execution based on flag
*
* @def THEN ( -- )
* End of IF conditional block
*
* @def ELSE ( -- )
* Alternative execution path
*
* @def BEGIN ( -- )
* Start of indefinite loop
*
* @def UNTIL ( flag -- )
* End loop if flag is true
*
* @def AGAIN ( -- )
* End infinite loop
*
* @def WHILE ( flag -- )
* Test condition in BEGIN loop
*
* @def REPEAT ( -- )
* End of WHILE loop
*
* @def DO ( limit start -- )
* Start definite loop
*
* @def LOOP ( -- )
* End DO loop, increment by 1
*
* @def +LOOP ( n -- )
* End DO loop, increment by n
*
* @def I ( -- n )
* Get current loop index
*
* @def J ( -- n )
* Get outer loop index
*
* @def LEAVE ( -- )
* Exit current loop
*
* @def UNLOOP ( -- )
* Discard loop parameters
*
* @def EXIT ( -- )
* Exit current word
*
* @def ABORT ( -- )
* Abort execution
*
* @def QUIT ( -- )
* Return to interpreter
*
* @def EXECUTE ( xt -- )
* Execute word at address
*
* @def BRANCH ( -- )
* Unconditional branch
*
* @def 0BRANCH ( flag -- )
* Branch if flag is zero
*
* @def (LIT) ( -- n )
* Push inline literal
* @}
*/
/**
* @brief Registers all control flow words with the Forth virtual machine
* @param vm Pointer to the Forth virtual machine instance
*/
void register_control_words(VM * vm);
#endif /* CONTROL_WORDS_H */
v3/src/word_source/include/defer_words.h
+17
View File
@@ -0,0 +1,17 @@
/*
StarForth — Steady-State Virtual Machine Runtime
Copyright (c) 2023–2025 Robert A. James
All rights reserved.
Licensed under the StarForth License, Version 1.0.
*/
#ifndef DEFER_WORDS_H
#define DEFER_WORDS_H
#include "../../../include/vm.h"
void register_defer_words(VM *vm);
#endif /* DEFER_WORDS_H */
v3/src/word_source/include/defining_words.h
+77
View File
@@ -0,0 +1,77 @@
/*
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.
*/
#ifndef DEFINING_WORDS_H
#define DEFINING_WORDS_H
#include "vm.h"
/**
* @defgroup DefiningWords FORTH-79 Defining Words
* @{
* @brief Standard FORTH-79 defining words
*
* @details These words are used for creating new dictionary entries and defining words:
* - : ( -- ) Start colon definition
* - ; ( -- ) End colon definition
* - CREATE ( -- ) Create dictionary entry
* - DOES> ( -- ) Define runtime behavior
* - <BUILDS ( -- ) Create word with <BUILDS/DOES>
* - CONSTANT ( n -- ) Define constant
* - VARIABLE ( -- ) Define variable
* - 2CONSTANT ( d -- ) Define double constant
* - 2VARIABLE ( -- ) Define double variable
* - USER ( n -- ) Define user variable
* - IMMEDIATE ( -- ) Make most recent word immediate
* - [COMPILE] ( -- ) Force compilation of immediate word
* - COMPILE ( -- ) Compile inline code
* - FORGET ( -- ) Remove word and all after it
* @}
*/
/*
* @brief Registers all FORTH-79 defining words with the virtual machine
* @param vm Pointer to the virtual machine instance
*/
void register_defining_words(VM * vm);
#endif /* DEFINING_WORDS_H */

Some files were not shown because too many files have changed in this diff Show More