Robert Allan JamesandClaude Sonnet 5
56ad128e2e
No shift primitive existed anywhere in the vendored VM word set. Adds both as FORTH-83-extension words next to INVERT, guarded against stack underflow and out-of-range shift counts (u >= 64). Their absence was masking a real bug: capsules/hermes/init.4th's CH-MINT-ID (item 4.2) calls LSHIFT to pack a 64-bit channel ID, which was silently tripping the capsule loader's forward-reference retry logic and splicing CH-REQUEST's body into CH-MINT-ID's definition. Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
454 lines
13 KiB
C
454 lines
13 KiB
C
/*
|
||
StarForth — Steady-State Virtual Machine Runtime
|
||
|
||
Copyright (c) 2023–2025 Robert A. James
|
||
All rights reserved.
|
||
|
||
This file is part of the StarForth project.
|
||
|
||
Licensed under the StarForth License, Version 1.0 (the "License");
|
||
you may not use this file except in compliance with the License.
|
||
|
||
You may obtain a copy of the License at:
|
||
https://github.com/star.4th@proton.me/StarForth/LICENSE.txt
|
||
|
||
This software is provided "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||
express or implied, including but not limited to the warranties of
|
||
merchantability, fitness for a particular purpose, and noninfringement.
|
||
|
||
See the License for the specific language governing permissions and
|
||
limitations under the License.
|
||
|
||
StarForth — Steady-State Virtual Machine Runtime
|
||
Copyright (c) 2023–2025 Robert A. James
|
||
All rights reserved.
|
||
|
||
This file is part of the StarForth project.
|
||
|
||
Licensed under the StarForth License, Version 1.0 (the "License");
|
||
you may not use this file except in compliance with the License.
|
||
|
||
You may obtain a copy of the License at:
|
||
https://github.com/star.4th@proton.me/StarForth/LICENSE.txt
|
||
|
||
This software is provided "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||
express or implied, including but not limited to the warranties of
|
||
merchantability, fitness for a particular purpose, and noninfringement.
|
||
|
||
See the License for the specific language governing permissions and
|
||
limitations under the License.
|
||
|
||
*/
|
||
|
||
/* logical_words.c - FORTH-79 Logical & Comparison Words */
|
||
#include "include/logical_words.h"
|
||
#include "../../include/log.h"
|
||
#include "../../include/word_registry.h"
|
||
|
||
|
||
/** @brief FORTH-79 TRUE value (-1, all bits set) */
|
||
#define FORTH_TRUE ((cell_t)-1)
|
||
/** @brief FORTH-79 FALSE value (0) */
|
||
#define FORTH_FALSE ((cell_t)0)
|
||
|
||
/**
|
||
* @brief FORTH word: AND ( n1 n2 -- n3 )
|
||
* @param vm Pointer to the virtual machine instance
|
||
*
|
||
* Performs bitwise AND operation on top two stack values.
|
||
* Stack effect: ( n1 n2 -- n3 ) where n3 = n1 AND n2
|
||
*/
|
||
static void logical_word_and(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
log_message(LOG_ERROR, "AND: 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, "AND: %ld AND %ld = %ld", (long) n1, (long) n2, (long) result);
|
||
}
|
||
|
||
/* OR - Bitwise OR ( n1 n2 -- n3 ) */
|
||
static void logical_word_or(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
log_message(LOG_ERROR, "OR: 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, "OR: %ld OR %ld = %ld", (long) n1, (long) n2, (long) result);
|
||
}
|
||
|
||
/* XOR - Bitwise XOR ( n1 n2 -- n3 ) */
|
||
static void logical_word_xor(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
log_message(LOG_ERROR, "XOR: 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, "XOR: %ld XOR %ld = %ld", (long) n1, (long) n2, (long) result);
|
||
}
|
||
|
||
/* NOT ( flag -- flag ) FORTH-79 logical NOT: 0 -> TRUE, non-zero -> FALSE */
|
||
static void logical_word_not(VM *vm) {
|
||
if (vm->dsp < 0) {
|
||
log_message(LOG_ERROR, "NOT: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n1 = vm_pop(vm);
|
||
cell_t result = (n1 == 0) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "NOT: %ld -> %ld", (long) n1, (long) result);
|
||
}
|
||
|
||
/* INVERT ( n1 -- n2 ) Bitwise complement (FORTH-83 extension) */
|
||
static void logical_word_invert(VM *vm) {
|
||
if (vm->dsp < 0) {
|
||
log_message(LOG_ERROR, "INVERT: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n1 = vm_pop(vm);
|
||
vm_push(vm, ~n1);
|
||
}
|
||
|
||
/* LSHIFT ( x1 u -- x2 ) Logical left shift, u bits (FORTH-83 extension) */
|
||
static void logical_word_lshift(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
log_message(LOG_ERROR, "LSHIFT: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
ucell_t u = (ucell_t) vm_pop(vm);
|
||
ucell_t x1 = (ucell_t) vm_pop(vm);
|
||
|
||
if (u >= (ucell_t)(sizeof(cell_t) * 8)) {
|
||
log_message(LOG_ERROR, "LSHIFT: shift count %lu out of range", (unsigned long) u);
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t result = (cell_t)(x1 << u);
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "LSHIFT: %lu << %lu = %ld", (unsigned long) x1, (unsigned long) u, (long) result);
|
||
}
|
||
|
||
/* RSHIFT ( x1 u -- x2 ) Logical right shift, u bits (FORTH-83 extension) */
|
||
static void logical_word_rshift(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
log_message(LOG_ERROR, "RSHIFT: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
ucell_t u = (ucell_t) vm_pop(vm);
|
||
ucell_t x1 = (ucell_t) vm_pop(vm);
|
||
|
||
if (u >= (ucell_t)(sizeof(cell_t) * 8)) {
|
||
log_message(LOG_ERROR, "RSHIFT: shift count %lu out of range", (unsigned long) u);
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t result = (cell_t)(x1 >> u);
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "RSHIFT: %lu >> %lu = %ld", (unsigned long) x1, (unsigned long) u, (long) result);
|
||
}
|
||
|
||
/* 0= - Test for zero ( n -- flag ) */
|
||
static void logical_word_zero_equals(VM *vm) {
|
||
if (vm->dsp < 0) {
|
||
log_message(LOG_ERROR, "0=: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n = vm_pop(vm);
|
||
cell_t result = (n == 0) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "0=: %ld = 0? %s", (long) n, (result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* 0< - Test for negative ( n -- flag ) */
|
||
static void logical_word_zero_less(VM *vm) {
|
||
if (vm->dsp < 0) {
|
||
log_message(LOG_ERROR, "0<: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n = vm_pop(vm);
|
||
cell_t result = (n < 0) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "0<: %ld < 0? %s", (long) n, (result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* 0> - Test for positive ( n -- flag ) */
|
||
static void logical_word_zero_greater(VM *vm) {
|
||
if (vm->dsp < 0) {
|
||
log_message(LOG_ERROR, "0>: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n = vm_pop(vm);
|
||
cell_t result = (n > 0) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "0>: %ld > 0? %s", (long) n, (result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* = - Test for equality ( n1 n2 -- flag ) */
|
||
static void logical_word_equals(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) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "=: %ld = %ld? %s", (long) n1, (long) n2, (result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* <> - Test for inequality ( n1 n2 -- flag ) */
|
||
static void logical_word_not_equals(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) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "<>: %ld <> %ld? %s", (long) n1, (long) n2, (result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* < - Test for less than ( n1 n2 -- flag ) */
|
||
static void logical_word_less_than(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) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "<: %ld < %ld? %s", (long) n1, (long) n2, (result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* > - Test for greater than ( n1 n2 -- flag ) */
|
||
static void logical_word_greater_than(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) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, ">: %ld > %ld? %s", (long) n1, (long) n2, (result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* >= - Greater than or equal ( n1 n2 -- flag ) */
|
||
static void logical_word_greater_equal(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) ? FORTH_TRUE : FORTH_FALSE;
|
||
vm_push(vm, result);
|
||
log_message(LOG_DEBUG, ">=: %ld >= %ld? %s", (long)n1, (long)n2,
|
||
(result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* <= - Less than or equal ( n1 n2 -- flag ) */
|
||
static void logical_word_less_equal(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) ? FORTH_TRUE : FORTH_FALSE;
|
||
vm_push(vm, result);
|
||
log_message(LOG_DEBUG, "<=: %ld <= %ld? %s", (long)n1, (long)n2,
|
||
(result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* U< - Unsigned less than ( u1 u2 -- flag ) */
|
||
static void logical_word_u_less_than(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
log_message(LOG_ERROR, "U<: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
uintptr_t u2 = (uintptr_t) vm_pop(vm);
|
||
uintptr_t u1 = (uintptr_t) vm_pop(vm);
|
||
cell_t result = (u1 < u2) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "U<: %lu U< %lu? %s", (unsigned long) u1, (unsigned long) u2,
|
||
(result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* U> - Unsigned greater than ( u1 u2 -- flag ) */
|
||
static void logical_word_u_greater_than(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
log_message(LOG_ERROR, "U>: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
uintptr_t u2 = (uintptr_t) vm_pop(vm);
|
||
uintptr_t u1 = (uintptr_t) vm_pop(vm);
|
||
cell_t result = (u1 > u2) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "U>: %lu U> %lu? %s", (unsigned long) u1, (unsigned long) u2,
|
||
(result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* WITHIN - Test if n is within bounds ( n low high -- flag ) */
|
||
static void logical_word_within(VM *vm) {
|
||
if (vm->dsp < 2) {
|
||
log_message(LOG_ERROR, "WITHIN: Stack underflow");
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t high = vm_pop(vm);
|
||
cell_t low = vm_pop(vm);
|
||
cell_t n = vm_pop(vm);
|
||
cell_t result = (n >= low && n < high) ? FORTH_TRUE : FORTH_FALSE;
|
||
|
||
vm_push(vm, result);
|
||
|
||
log_message(LOG_DEBUG, "WITHIN: %ld <= %ld < %ld? %s", (long) low, (long) n, (long) high,
|
||
(result == FORTH_TRUE) ? "TRUE" : "FALSE");
|
||
}
|
||
|
||
/* TRUE constant */
|
||
static void logical_word_true(VM *vm) {
|
||
vm_push(vm, FORTH_TRUE);
|
||
log_message(LOG_DEBUG, "TRUE: Pushed -1");
|
||
}
|
||
|
||
/* FALSE constant */
|
||
static void logical_word_false(VM *vm) {
|
||
vm_push(vm, FORTH_FALSE);
|
||
log_message(LOG_DEBUG, "FALSE: Pushed 0");
|
||
}
|
||
|
||
/* 0<> ( n -- f ) push TRUE (-1) if TOS != 0 else FALSE (0) */
|
||
void logical_word_zero_not_equal(VM *vm) {
|
||
if (vm->dsp < 0) {
|
||
/* underflow guard: need 1 item */
|
||
vm->error = 1;
|
||
log_message(LOG_ERROR, "0<>: stack underflow");
|
||
return;
|
||
}
|
||
cell_t x = vm_pop(vm);
|
||
vm_push(vm, x != 0 ? -1 : 0); /* Forth truth values: -1 true, 0 false */
|
||
}
|
||
|
||
/**
|
||
* @brief Registers all FORTH-79 logical and comparison words with the VM
|
||
* @param vm Pointer to the virtual machine instance
|
||
*
|
||
* Registers logical operations (AND, OR, XOR, NOT),
|
||
* comparison operations (=, <>, <, >, etc.),
|
||
* and constant words (TRUE, FALSE) with the virtual machine.
|
||
*/
|
||
void register_logical_words(VM *vm) {
|
||
/* Bitwise operations */
|
||
register_word(vm, "AND", logical_word_and);
|
||
register_word(vm, "OR", logical_word_or);
|
||
register_word(vm, "XOR", logical_word_xor);
|
||
register_word(vm, "NOT", logical_word_not);
|
||
register_word(vm, "INVERT", logical_word_invert);
|
||
register_word(vm, "LSHIFT", logical_word_lshift);
|
||
register_word(vm, "RSHIFT", logical_word_rshift);
|
||
|
||
/* Zero comparisons */
|
||
register_word(vm, "0=", logical_word_zero_equals);
|
||
register_word(vm, "0<", logical_word_zero_less);
|
||
register_word(vm, "0>", logical_word_zero_greater);
|
||
register_word(vm, "0<>", logical_word_zero_not_equal);
|
||
|
||
/* Comparisons */
|
||
register_word(vm, "=", logical_word_equals);
|
||
register_word(vm, "<>", logical_word_not_equals);
|
||
register_word(vm, "<", logical_word_less_than);
|
||
register_word(vm, ">", logical_word_greater_than);
|
||
register_word(vm, ">=", logical_word_greater_equal);
|
||
register_word(vm, "<=", logical_word_less_equal);
|
||
|
||
/* Unsigned comparisons */
|
||
register_word(vm, "U<", logical_word_u_less_than);
|
||
register_word(vm, "U>", logical_word_u_greater_than);
|
||
|
||
/* Range test */
|
||
register_word(vm, "WITHIN", logical_word_within);
|
||
|
||
/* Constants */
|
||
register_word(vm, "TRUE", logical_word_true);
|
||
register_word(vm, "FALSE", logical_word_false);
|
||
} |