;; 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-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)
    (dict
      "passed"
      forth-p4-passed
      "failed"
      forth-p4-failed
      "failures"
      forth-p4-failures)))