rose-ash/lib/forth/tests/test-phase4.sx

;; Phase 4 — strings + more Core.
;; Uses the byte-memory model on state ("mem" dict + "here" cursor).

(define forth-p4-passed 0)
(define forth-p4-failed 0)
(define forth-p4-failures (list))

(define
  forth-p4-assert
  (fn
    (label expected actual)
    (if
      (= expected actual)
      (set! forth-p4-passed (+ forth-p4-passed 1))
      (begin
        (set! forth-p4-failed (+ forth-p4-failed 1))
        (set!
          forth-p4-failures
          (concat
            forth-p4-failures
            (list
              (str label ": expected " (str expected) " got " (str actual)))))))))

(define
  forth-p4-check-output
  (fn
    (label src expected)
    (let ((r (forth-run src))) (forth-p4-assert label expected (nth r 1)))))

(define
  forth-p4-check-stack-size
  (fn
    (label src expected-n)
    (let
      ((r (forth-run src)))
      (forth-p4-assert label expected-n (len (nth r 2))))))

(define
  forth-p4-check-top
  (fn
    (label src expected)
    (let
      ((r (forth-run src)))
      (let
        ((stk (nth r 2)))
        (forth-p4-assert label expected (nth stk (- (len stk) 1)))))))

(define
  forth-p4-check-typed
  (fn
    (label src expected)
    (forth-p4-check-output label (str src " TYPE") expected)))

(define
  forth-p4-string-tests
  (fn
    ()
    (forth-p4-check-typed
      "S\" + TYPE — hello"
      "S\" HELLO\""
      "HELLO")
    (forth-p4-check-typed
      "S\" + TYPE — two words"
      "S\" HELLO WORLD\""
      "HELLO WORLD")
    (forth-p4-check-typed
      "S\" + TYPE — empty"
      "S\" \""
      "")
    (forth-p4-check-typed
      "S\" + TYPE — single char"
      "S\" X\""
      "X")
    (forth-p4-check-stack-size
      "S\" pushes (addr len)"
      "S\" HI\""
      2)
    (forth-p4-check-top
      "S\" length is correct"
      "S\" HELLO\""
      5)
    (forth-p4-check-output
      ".\" prints at interpret time"
      ".\" HELLO\""
      "HELLO")
    (forth-p4-check-output
      ".\" in colon def"
      ": GREET .\" HI \" ; GREET GREET"
      "HI HI ")))

(define
  forth-p4-count-tests
  (fn
    ()
    (forth-p4-check-typed
      "C\" + COUNT + TYPE"
      "C\" ABC\" COUNT"
      "ABC")
    (forth-p4-check-typed
      "C\" then COUNT leaves right len"
      "C\" HI THERE\" COUNT"
      "HI THERE")))

(define
  forth-p4-fill-tests
  (fn
    ()
    (forth-p4-check-typed
      "FILL overwrites prefix bytes"
      "S\" ABCDE\" 2DUP DROP 3 65 FILL"
      "AAADE")
    (forth-p4-check-typed
      "BLANK sets spaces"
      "S\" XYZAB\" 2DUP DROP 3 BLANK"
      "   AB")))

(define
  forth-p4-cmove-tests
  (fn
    ()
    (forth-p4-check-output
      "CMOVE copies HELLO forward"
      ": MKH 72 0 C! 69 1 C! 76 2 C! 76 3 C! 79 4 C! ;
       : T MKH 0 10 5 CMOVE 10 5 TYPE ; T"
      "HELLO")
    (forth-p4-check-output
      "CMOVE> copies overlapping backward"
      ": MKA 65 0 C! 66 1 C! 67 2 C! ;
       : T MKA 0 1 2 CMOVE> 0 3 TYPE ; T"
      "AAB")
    (forth-p4-check-output
      "MOVE picks direction for overlap"
      ": MKA 65 0 C! 66 1 C! 67 2 C! ;
       : T MKA 0 1 2 MOVE 0 3 TYPE ; T"
      "AAB")))

(define
  forth-p4-charplus-tests
  (fn
    ()
    (forth-p4-check-top
      "CHAR+ increments"
      "5 CHAR+"
      6)))

(define
  forth-p4-char-tests
  (fn
    ()
    (forth-p4-check-top "CHAR A -> 65" "CHAR A" 65)
    (forth-p4-check-top "CHAR x -> 120" "CHAR x" 120)
    (forth-p4-check-top "CHAR takes only first char" "CHAR HELLO" 72)
    (forth-p4-check-top
      "[CHAR] compiles literal"
      ": AA [CHAR] A ; AA"
      65)
    (forth-p4-check-top
      "[CHAR] reads past IMMEDIATE"
      ": ZZ [CHAR] Z ; ZZ"
      90)
    (forth-p4-check-stack-size
      "[CHAR] doesn't leak at compile time"
      ": FOO [CHAR] A ; "
      0)))

(define
  forth-p4-key-accept-tests
  (fn
    ()
    (let
      ((r (forth-run "1000 2 ACCEPT")))
      (let ((stk (nth r 2))) (forth-p4-assert "ACCEPT empty buf -> 0" (list 0) stk)))))

(define
  forth-p4-shift-tests
  (fn
    ()
    (forth-p4-check-top "1 0 LSHIFT" "1 0 LSHIFT" 1)
    (forth-p4-check-top "1 1 LSHIFT" "1 1 LSHIFT" 2)
    (forth-p4-check-top "1 2 LSHIFT" "1 2 LSHIFT" 4)
    (forth-p4-check-top "1 15 LSHIFT" "1 15 LSHIFT" 32768)
    (forth-p4-check-top "1 31 LSHIFT" "1 31 LSHIFT" -2147483648)
    (forth-p4-check-top "1 0 RSHIFT" "1 0 RSHIFT" 1)
    (forth-p4-check-top "1 1 RSHIFT" "1 1 RSHIFT" 0)
    (forth-p4-check-top "2 1 RSHIFT" "2 1 RSHIFT" 1)
    (forth-p4-check-top "4 2 RSHIFT" "4 2 RSHIFT" 1)
    (forth-p4-check-top "-1 1 RSHIFT (logical, not arithmetic)" "-1 1 RSHIFT" 2147483647)
    (forth-p4-check-top "MSB via 1S 1 RSHIFT INVERT" "0 INVERT 1 RSHIFT INVERT" -2147483648)))

(define
  forth-p4-sp-tests
  (fn
    ()
    (forth-p4-check-top "SP@ returns depth (0)" "SP@" 0)
    (forth-p4-check-top
      "SP@ after pushes"
      "1 2 3 SP@ SWAP DROP SWAP DROP SWAP DROP"
      3)
    (forth-p4-check-stack-size
      "SP! truncates"
      "1 2 3 4 5 2 SP!"
      2)
    (forth-p4-check-top
      "SP! leaves base items intact"
      "1 2 3 4 5 2 SP!"
      2)))

(define
  forth-p4-base-tests
  (fn
    ()
    (forth-p4-check-top
      "BASE default is 10"
      "BASE @"
      10)
    (forth-p4-check-top
      "HEX switches base to 16"
      "HEX BASE @"
      16)
    (forth-p4-check-top
      "DECIMAL resets to 10"
      "HEX DECIMAL BASE @"
      10)
    (forth-p4-check-top
      "HEX parses 10 as 16"
      "HEX 10"
      16)
    (forth-p4-check-top
      "HEX parses FF as 255"
      "HEX FF"
      255)
    (forth-p4-check-top
      "DECIMAL parses 10 as 10"
      "HEX DECIMAL 10"
      10)
    (forth-p4-check-top
      "BIN parses 1010 as 10"
      "BIN 1010"
      10)
    (forth-p4-check-top
      "OCTAL parses 17 as 15"
      "OCTAL 17"
      15)
    (forth-p4-check-top
      "BASE @ ; 16 BASE ! ; BASE @"
      "BASE @ 16 BASE ! BASE @ SWAP DROP"
      16)))

(define
  forth-p4-run-all
  (fn
    ()
    (set! forth-p4-passed 0)
    (set! forth-p4-failed 0)
    (set! forth-p4-failures (list))
    (forth-p4-string-tests)
    (forth-p4-count-tests)
    (forth-p4-fill-tests)
    (forth-p4-cmove-tests)
    (forth-p4-charplus-tests)
    (forth-p4-char-tests)
    (forth-p4-key-accept-tests)
    (forth-p4-base-tests)
    (forth-p4-shift-tests)
    (forth-p4-sp-tests)
    (dict
      "passed"
      forth-p4-passed
      "failed"
      forth-p4-failed
      "failures"
      forth-p4-failures)))