rajamesandJunie
a8b70e88d3
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>
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);
|
||
} |