353 lines
10 KiB
C
353 lines
10 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.
|
||
|
||
*/
|
||
|
||
/* mixed_arithmetic_words.c - FORTH-79 Mixed Arithmetic Words */
|
||
#include "include/mixed_arithmetic_words.h"
|
||
#include "../../include/word_registry.h"
|
||
#include "../../include/log.h"
|
||
|
||
/* Implementation of FORTH-79 Mixed Arithmetic Words */
|
||
|
||
/**
|
||
* @brief M+ ( d n -- d )
|
||
*
|
||
* Adds the single-cell signed integer @c n to the double-cell value @c d,
|
||
* producing a new double-cell result. Handles carry propagation: if the low
|
||
* cell addition overflows a positive @c n, the high cell is incremented; if it
|
||
* underflows a negative @c n, the high cell is decremented.
|
||
*
|
||
* Stack effect: ( d_high d_low n -- d_high' d_low' )
|
||
*
|
||
* @param vm Active VM; sets @c vm->error = 1 on stack underflow
|
||
*/
|
||
void mixed_math_word_m_plus(VM *vm) {
|
||
if (vm->dsp < 2) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n = vm_pop(vm); // single
|
||
cell_t dlow = vm_pop(vm); // low part of double
|
||
cell_t dhigh = vm_pop(vm); // high part of double
|
||
|
||
cell_t old_dlow = dlow;
|
||
dlow += n;
|
||
|
||
if (n > 0 && dlow < old_dlow) {
|
||
dhigh++;
|
||
} else if (n < 0 && dlow > old_dlow) {
|
||
dhigh--;
|
||
}
|
||
|
||
// Push high first, then low (low is TOS)
|
||
vm_push(vm, dhigh);
|
||
vm_push(vm, dlow);
|
||
}
|
||
|
||
/**
|
||
* @brief M- ( d n -- d )
|
||
*
|
||
* Subtracts the single-cell signed integer @c n from the double-cell value @c d,
|
||
* producing a new double-cell result. Mirrors @c M+ carry logic: a positive @c n
|
||
* that causes the low cell to wrap below zero decrements the high cell, and vice versa.
|
||
*
|
||
* Stack effect: ( d_high d_low n -- d_high' d_low' )
|
||
*
|
||
* @param vm Active VM; sets @c vm->error = 1 on stack underflow
|
||
*/
|
||
void mixed_math_word_m_minus(VM *vm) {
|
||
if (vm->dsp < 2) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n = vm_pop(vm);
|
||
cell_t dlow = vm_pop(vm);
|
||
cell_t dhigh = vm_pop(vm);
|
||
|
||
cell_t old_dlow = dlow;
|
||
dlow -= n;
|
||
|
||
if (n > 0 && dlow > old_dlow) {
|
||
dhigh--;
|
||
} else if (n < 0 && dlow < old_dlow) {
|
||
dhigh++;
|
||
}
|
||
|
||
vm_push(vm, dhigh);
|
||
vm_push(vm, dlow);
|
||
}
|
||
|
||
/**
|
||
* @brief M* ( n1 n2 -- d )
|
||
*
|
||
* Multiplies two single-cell signed integers, producing a double-cell result.
|
||
* On 64-bit builds the product is computed via @c long long and the low 32 bits
|
||
* go to the deeper stack cell while the high 32 bits go to TOS. On 32-bit builds
|
||
* the result fits in a single cell so the high cell is pushed as 0.
|
||
*
|
||
* Stack effect: ( n1 n2 -- d_low d_high ) TOS = high
|
||
*
|
||
* @param vm Active VM; sets @c vm->error = 1 on stack underflow
|
||
*/
|
||
void mixed_math_word_m_star(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n2 = vm_pop(vm);
|
||
cell_t n1 = vm_pop(vm);
|
||
|
||
if (sizeof(cell_t) == 8) {
|
||
long long result = (long long) n1 * (long long) n2;
|
||
cell_t dlow = (cell_t)(result & 0xFFFFFFFFLL);
|
||
cell_t dhigh = (cell_t)(result >> 32);
|
||
vm_push(vm, dlow); // lo first
|
||
vm_push(vm, dhigh); // hi last (TOS)
|
||
} else {
|
||
cell_t result = n1 * n2;
|
||
vm_push(vm, result);
|
||
vm_push(vm, 0);
|
||
}
|
||
}
|
||
|
||
/**
|
||
* @brief M/MOD ( d n -- rem quot )
|
||
*
|
||
* Divides the double-cell dividend @c d by the single-cell divisor @c n,
|
||
* pushing the remainder deeper and the quotient on TOS. On 64-bit builds,
|
||
* the double is reconstructed as a @c long long by shifting the high 32 bits
|
||
* left; the UBSan-safe path uses an unsigned shift before casting to signed to
|
||
* avoid undefined behaviour on negative values. On 32-bit builds, only handles
|
||
* the case where the high cell is zero; sets @c vm->error = 1 otherwise.
|
||
*
|
||
* Stack effect: ( d_high d_low n -- remainder quotient ) TOS = quotient
|
||
*
|
||
* @param vm Active VM; sets @c vm->error = 1 on underflow or division by zero
|
||
*/
|
||
void mixed_math_word_m_slash_mod(VM *vm) {
|
||
if (vm->dsp < 2) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n = vm_pop(vm);
|
||
cell_t dlow = vm_pop(vm);
|
||
cell_t dhigh = vm_pop(vm);
|
||
|
||
if (n == 0) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
if (sizeof(cell_t) == 8) {
|
||
/* UBSan fix: Perform shift on unsigned, then cast to signed (2025-12-09)
|
||
* Left-shifting negative signed values is undefined behavior */
|
||
long long dividend = (long long)(((unsigned long long) dhigh << 32) |
|
||
((unsigned long long) dlow & 0xFFFFFFFFLL));
|
||
cell_t quotient = (cell_t)(dividend / n);
|
||
cell_t remainder = (cell_t)(dividend % n);
|
||
vm_push(vm, remainder); // remainder first (deeper)
|
||
vm_push(vm, quotient); // quotient last (TOS)
|
||
} else {
|
||
if (dhigh == 0) {
|
||
vm_push(vm, dlow % n);
|
||
vm_push(vm, dlow / n);
|
||
} else {
|
||
vm->error = 1; // 128-bit not yet implemented
|
||
}
|
||
}
|
||
}
|
||
|
||
/**
|
||
* @brief MOD ( n1 n2 -- r )
|
||
*
|
||
* Computes @c n1 % @c n2, leaving the remainder on the stack. Sets
|
||
* @c vm->error = 1 if @c n2 is zero (division by zero guard).
|
||
*
|
||
* Stack effect: ( n1 n2 -- remainder )
|
||
*
|
||
* @param vm Active VM; sets @c vm->error = 1 on underflow or zero divisor
|
||
*/
|
||
void mixed_math_word_mod(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n2 = vm_pop(vm);
|
||
cell_t n1 = vm_pop(vm);
|
||
|
||
if (n2 == 0) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
vm_push(vm, n1 % n2);
|
||
}
|
||
|
||
/**
|
||
* @brief /MOD ( n1 n2 -- rem quot )
|
||
*
|
||
* Divides @c n1 by @c n2, pushing the remainder deeper and the quotient on TOS.
|
||
* Sets @c vm->error = 1 if @c n2 is zero.
|
||
*
|
||
* Stack effect: ( n1 n2 -- remainder quotient ) TOS = quotient
|
||
*
|
||
* @param vm Active VM; sets @c vm->error = 1 on underflow or zero divisor
|
||
*/
|
||
void mixed_math_word_slash_mod(VM *vm) {
|
||
if (vm->dsp < 1) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n2 = vm_pop(vm);
|
||
cell_t n1 = vm_pop(vm);
|
||
|
||
if (n2 == 0) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t quotient = n1 / n2;
|
||
cell_t remainder = n1 % n2;
|
||
vm_push(vm, remainder); // deeper
|
||
vm_push(vm, quotient); // TOS
|
||
}
|
||
|
||
/**
|
||
* @brief STAR-SLASH (FORTH word: @c *-/ ) — multiply then divide. ( n1 n2 n3 -- n4 )
|
||
*
|
||
* Computes @c (n1 * n2) / n3 using a @c long long intermediate on 64-bit builds
|
||
* to avoid intermediate overflow. On 32-bit builds falls back to @c long double.
|
||
* Sets @c vm->error = 1 if @c n3 is zero.
|
||
*
|
||
* Stack effect: ( n1 n2 n3 -- quotient )
|
||
*
|
||
* @param vm Active VM; sets @c vm->error = 1 on underflow or zero divisor
|
||
*/
|
||
void mixed_math_word_star_slash(VM *vm) {
|
||
if (vm->dsp < 2) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n3 = vm_pop(vm);
|
||
cell_t n2 = vm_pop(vm);
|
||
cell_t n1 = vm_pop(vm);
|
||
|
||
if (n3 == 0) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
if (sizeof(cell_t) == 8) {
|
||
long long intermediate = (long long) n1 * (long long) n2;
|
||
vm_push(vm, (cell_t)(intermediate / n3));
|
||
} else {
|
||
long double intermediate = (long double) n1 * (long double) n2;
|
||
vm_push(vm, (cell_t)(intermediate / n3));
|
||
}
|
||
}
|
||
|
||
/**
|
||
* @brief STAR-SLASH-MOD (FORTH word: @c *-/MOD ) — multiply then divide, leaving remainder. ( n1 n2 n3 -- rem quot )
|
||
*
|
||
* Computes @c (n1 * n2) / n3 and leaves both the remainder (deeper) and
|
||
* quotient (TOS). Uses @c long long on 64-bit builds; falls back to
|
||
* @c long double with integer remainder reconstruction on 32-bit builds.
|
||
* Sets @c vm->error = 1 if @c n3 is zero.
|
||
*
|
||
* Stack effect: ( n1 n2 n3 -- remainder quotient ) TOS = quotient
|
||
*
|
||
* @param vm Active VM; sets @c vm->error = 1 on underflow or zero divisor
|
||
*/
|
||
void mixed_math_word_star_slash_mod(VM *vm) {
|
||
if (vm->dsp < 2) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
cell_t n3 = vm_pop(vm);
|
||
cell_t n2 = vm_pop(vm);
|
||
cell_t n1 = vm_pop(vm);
|
||
|
||
if (n3 == 0) {
|
||
vm->error = 1;
|
||
return;
|
||
}
|
||
|
||
if (sizeof(cell_t) == 8) {
|
||
long long intermediate = (long long) n1 * (long long) n2;
|
||
cell_t quotient = (cell_t)(intermediate / n3);
|
||
cell_t remainder = (cell_t)(intermediate % n3);
|
||
vm_push(vm, remainder); // remainder deeper
|
||
vm_push(vm, quotient); // quotient TOS
|
||
} else {
|
||
long double intermediate = (long double) n1 * (long double) n2;
|
||
cell_t quotient = (cell_t)(intermediate / n3);
|
||
cell_t remainder = n1 * n2 - quotient * n3;
|
||
vm_push(vm, remainder);
|
||
vm_push(vm, quotient);
|
||
}
|
||
}
|
||
|
||
/**
|
||
* @brief Register all FORTH-79 mixed arithmetic words with the VM dictionary.
|
||
*
|
||
* Registers: @c M+, @c M-, @c M*, @c M/MOD, @c MOD, @c /MOD, @c *\/,
|
||
* @c *\/MOD. Called during VM bootstrap.
|
||
*
|
||
* @param vm Active VM to register words into
|
||
*/
|
||
void register_mixed_arithmetic_words(VM *vm) {
|
||
register_word(vm, "M+", mixed_math_word_m_plus);
|
||
register_word(vm, "M-", mixed_math_word_m_minus);
|
||
register_word(vm, "M*", mixed_math_word_m_star);
|
||
register_word(vm, "M/MOD", mixed_math_word_m_slash_mod);
|
||
register_word(vm, "MOD", mixed_math_word_mod);
|
||
register_word(vm, "/MOD", mixed_math_word_slash_mod);
|
||
register_word(vm, "*/", mixed_math_word_star_slash);
|
||
register_word(vm, "*/MOD", mixed_math_word_star_slash_mod);
|
||
} |