rose-ash/lib/forth/runtime.sx

;; lib/forth/runtime.sx — Forth primitives on SX
;;
;; Provides Forth-idiomatic wrappers over SX built-ins.
;; Primitives used:
;;   bitwise-and/or/xor/not/arithmetic-shift/bit-count (Phase 7)
;;   make-bytevector/bytevector-u8-ref/u8-set!/...     (Phase 20)
;;   quotient/remainder/modulo                          (Phase 15 / builtin)
;;
;; Naming: SX identifiers can't include @ or !-alone, so Forth words are:
;;   C@ → forth-cfetch    C! → forth-cstore
;;   @  → forth-fetch     !  → forth-store

;; ---------------------------------------------------------------------------
;; 1. Bitwise operations — Forth core words
;;    Forth TRUE = -1 (all bits set), FALSE = 0.
;;    All ops coerce to integer via truncate.
;; ---------------------------------------------------------------------------

(define (forth-and a b) (bitwise-and (truncate a) (truncate b)))
(define (forth-or a b) (bitwise-or (truncate a) (truncate b)))
(define (forth-xor a b) (bitwise-xor (truncate a) (truncate b)))

;; INVERT — bitwise NOT (Forth NOT is logical; INVERT is bitwise)
(define (forth-invert a) (bitwise-not (truncate a)))

;; LSHIFT RSHIFT — n bit — shift a by n positions
(define (forth-lshift a n) (arithmetic-shift (truncate a) (truncate n)))
(define
  (forth-rshift a n)
  (arithmetic-shift (truncate a) (- 0 (truncate n))))

;; 2* 2/ — multiply/divide by 2 via bit shift
(define (forth-2* a) (arithmetic-shift (truncate a) 1))
(define (forth-2/ a) (arithmetic-shift (truncate a) -1))

;; BIT-COUNT — number of set bits (Kernighan popcount)
(define (forth-bit-count a) (bit-count (truncate a)))

;; INTEGER-LENGTH — index of highest set bit (0 for zero)
(define (forth-integer-length a) (integer-length (truncate a)))

;; WITHIN — ( u ul uh -- flag ) true if ul <= u < uh
(define (forth-within u ul uh) (and (>= u ul) (< u uh)))

;; Arithmetic complements commonly used alongside bitwise ops
(define (forth-negate a) (- 0 (truncate a)))
(define (forth-abs a) (abs (truncate a)))
(define (forth-min a b) (if (< a b) a b))
(define (forth-max a b) (if (> a b) a b))
(define (forth-mod a b) (modulo (truncate a) (truncate b)))

;; /MOD — ( n1 n2 -- rem quot ) returns list (remainder quotient)
(define
  (forth-divmod a b)
  (list
    (remainder (truncate a) (truncate b))
    (quotient (truncate a) (truncate b))))

;; ---------------------------------------------------------------------------
;; 2. String buffer — word-definition / string accumulation
;;    EMIT appends one char; TYPE appends a string.
;;    Value is retrieved with forth-sb-value.
;; ---------------------------------------------------------------------------

(define
  (forth-sb-new)
  (let
    ((sb (dict)))
    (dict-set! sb "_forth_sb" true)
    (dict-set! sb "_chars" (list))
    sb))

(define (forth-sb? v) (and (dict? v) (dict-has? v "_forth_sb")))

;; EMIT — append one character
(define
  (forth-sb-emit! sb c)
  (dict-set! sb "_chars" (append (get sb "_chars") (list c)))
  sb)

;; TYPE — append a string
(define
  (forth-sb-type! sb s)
  (dict-set! sb "_chars" (append (get sb "_chars") (string->list s)))
  sb)

(define (forth-sb-value sb) (list->string (get sb "_chars")))

(define (forth-sb-length sb) (len (get sb "_chars")))

(define (forth-sb-clear! sb) (dict-set! sb "_chars" (list)) sb)

;; Emit integer as decimal digits
(define (forth-sb-emit-int! sb n) (forth-sb-type! sb (str (truncate n))))

;; ---------------------------------------------------------------------------
;; 3. Memory / Bytevectors — Forth raw memory model
;;    ALLOT allocates a bytevector. Byte and cell (32-bit LE) access.
;; ---------------------------------------------------------------------------

;; ALLOT — allocate n bytes zero-initialised
(define (forth-mem-new n) (make-bytevector (truncate n) 0))

(define (forth-mem? v) (bytevector? v))

(define (forth-mem-size v) (bytevector-length v))

;; C@ C! — byte fetch/store
(define (forth-cfetch mem addr) (bytevector-u8-ref mem (truncate addr)))

(define
  (forth-cstore mem addr val)
  (bytevector-u8-set!
    mem
    (truncate addr)
    (modulo (truncate val) 256))
  mem)

;; @ ! — 32-bit little-endian cell fetch/store
(define
  (forth-fetch mem addr)
  (let
    ((a (truncate addr)))
    (+
      (bytevector-u8-ref mem a)
      (* 256 (bytevector-u8-ref mem (+ a 1)))
      (* 65536 (bytevector-u8-ref mem (+ a 2)))
      (* 16777216 (bytevector-u8-ref mem (+ a 3))))))

(define
  (forth-store mem addr val)
  (let
    ((a (truncate addr)) (v (truncate val)))
    (bytevector-u8-set! mem a (modulo v 256))
    (bytevector-u8-set!
      mem
      (+ a 1)
      (modulo (quotient v 256) 256))
    (bytevector-u8-set!
      mem
      (+ a 2)
      (modulo (quotient v 65536) 256))
    (bytevector-u8-set!
      mem
      (+ a 3)
      (modulo (quotient v 16777216) 256)))
  mem)

;; MOVE — copy count bytes from src[src-addr] to dst[dst-addr]
(define
  (forth-move! src src-addr dst dst-addr count)
  (letrec
    ((go (fn (i) (when (< i (truncate count)) (bytevector-u8-set! dst (+ (truncate dst-addr) i) (bytevector-u8-ref src (+ (truncate src-addr) i))) (go (+ i 1))))))
    (go 0))
  dst)

;; FILL — fill count bytes at addr with byte value
(define
  (forth-fill! mem addr count byte)
  (letrec
    ((go (fn (i) (when (< i (truncate count)) (bytevector-u8-set! mem (+ (truncate addr) i) (modulo (truncate byte) 256)) (go (+ i 1))))))
    (go 0))
  mem)

;; ERASE — fill with zeros (Forth: ERASE)
(define
  (forth-erase! mem addr count)
  (forth-fill! mem addr count 0))

;; Dump memory region as list of byte values
(define
  (forth-mem->list mem addr count)
  (letrec
    ((go (fn (i acc) (if (= i 0) acc (go (- i 1) (cons (bytevector-u8-ref mem (+ (truncate addr) (- i 1))) acc))))))
    (go (truncate count) (list))))