Files
LithosAnanake/src/word_source/block_words.c
T
Robert Allan JamesandClaude Sonnet 5 cc6c8c43f3 Fix ABORT to actually unwind to QUIT instead of one level
ABORT is documented and tested in this codebase as standard FORTH-79
behavior -- system_words_test.c:63: "Should clear stacks and return to
QUIT" -- meaning it should unwind all the way back to the outermost
interpreter loop, abandoning whatever's left of the current line/block.
The implementation only unwound one level: every place that checked
vm->abort_requested cleared it the instant it saw it, so it never
survived to propagate past the first nested frame.

This surfaced via Artemis's ART-HALT-UNRECOG (capsules/artemis/init.4th):
on an unrecognized disk it correctly printed "ARTEMIS HALT: unrecognized
disk content" and called ABORT, but WELCOME (the next line in the same
block) ran anyway, and Artemis announced ready to Hermes and joined the
fleet normally -- contradicting .claude/ARTEMIS.md's "Refuse to mount...
do not overwrite it" requirement. Root cause is general, not
Artemis-specific, and present identically in both the hosted and kernel
VM cores.

Fixed at every level execution can nest through, verified by exhaustively
grepping every !vm->error-gated continuation loop and adding the parallel
!vm->abort_requested check:

- execute_colon_word (src/vm.c, src/starkernel/vm/vm_core.c): stop
  clearing the flag on return -- every colon-word call is a recursive
  call to this same function, so leaving it set lets every enclosing
  frame's own check also unwind.
- vm_interpret (src/vm.c, src/starkernel/vm/vm_core.c): stop parsing
  further words in the current input string once the flag is set.
- exec_block_with_retry (src/starkernel/capsule/capsule_loader.c):
  capsule birth's line-by-line block executor -- stop processing further
  lines in the current block, but return 0 (not -1), so
  capsule_exec_payload still loads later blocks in the same capsule
  payload. Returning -1 here would have silently broken word definitions
  in blocks that come after the aborting one for reasons unrelated to
  why it aborted (concretely, Artemis's ART-PING/LOAD-DOE in blocks
  4851/4852, which follow the entry block 4133).
- THRU and --> (src/word_source/block_words.c): stop processing further
  blocks/lines in their own loops.
- DODOES (src/word_source/defining_words.c): the CREATE...DOES> runtime
  has its own hand-rolled execution loop, separate from
  execute_colon_word -- same bug class, same fix. Also guarded the
  post-loop "if (vm->rsp < base_rsp) vm->rsp = base_rsp" clamp so it
  doesn't fire on an abort exit -- ABORT's own reset_vm_state() already
  set rsp; restoring it to base_rsp would have partially undone that.
- Both REPL loops (src/repl.c, src/starkernel/repl.c x2 call sites):
  clear the flag after each line, mirroring the existing vm->error
  pattern, so a mid-line abort doesn't silently freeze subsequent
  interactive input.

Verified directly: ": AB-TEST 1 2 3 ABORT 999 . ;  AB-TEST 42 . CR
777 . CR" -- 999 never prints (stops mid-colon-word), 42 never prints
(stops the rest of the same line), 777 prints fine (next line
unaffected). Artemis: WELCOME/"Artemis ready" no longer fires after the
halt message. No regression: all three architectures still show PASS:
persist-read, PASS: E2E msg flow, and matching dict_hash on the normal
(non-aborted) boot path; hosted test suite 965 passed / 0 failed.

Known follow-up, not fixed here (see memory for details): Artemis still
announces ready to Hermes via a separate call path (CD-INIT, block 4141)
that never went through capsule_exec_payload's block chain in the first
place, and the disk file still picks up incidental writes even on a
correctly-halted boot -- likely generic block-subsystem housekeeping,
not traced yet.

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
2026-08-02 10:07:18 -04:00

468 lines
14 KiB
C
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
/*
StarForth — Steady-State Virtual Machine Runtime
Copyright (c) 20232025 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) 20232025 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>
/* ----------------------------------------------------------------------
* 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 ----------------------------------------- */
/* Find the slot holding lbn; return slot index or -1 if not loaded. */
static int blk_vm_find(VM *vm, uint32_t lbn) {
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. */
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;
memcpy(vm->blk_vm_cbuf[s], 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. */
static void blk_vm_flush_all(VM *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;
memcpy(vm->blk_vm_cbuf[i], 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; }
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; }
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 */
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; }
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;
memcpy(vm->blk_vm_cbuf[s], vm->memory + base, BLOCK_SIZE);
vm->blk_vm_dirty[s] = 1;
blk_update((uint32_t) blk);
}
/* 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;
}
}
}
/* --- 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, "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);
}