;; Phase 2 — colon definitions + compile mode + variables/values/fetch/store.

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

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

(define
  forth-p2-check-stack
  (fn
    (label src expected)
    (let ((r (forth-run src))) (forth-p2-assert label expected (nth r 2)))))

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

(define
  forth-p2-colon-tests
  (fn
    ()
    (forth-p2-check-stack "simple colon" ": DOUBLE 2 * ; 7 DOUBLE" (list 14))
    (forth-p2-check-stack "three-op body" ": ADD3 + + ; 1 2 3 ADD3" (list 6))
    (forth-p2-check-stack
      "nested call"
      ": SQR DUP * ; : SOS SQR SWAP SQR + ; 3 4 SOS"
      (list 25))
    (forth-p2-check-stack
      "deep chain"
      ": D 2 ; : B D ; : A B D * ; A"
      (list 4))
    (forth-p2-check-stack
      "colon uses literal"
      ": FOO 1 2 + ; FOO FOO +"
      (list 6))
    (forth-p2-check-stack "case-insensitive def" ": BAR 9 ; bar" (list 9))
    (forth-p2-check-stack
      "redefinition picks newest"
      ": F 1 ; : F 2 ; F"
      (list 2))
    (forth-p2-check-stack
      "negative literal in def"
      ": NEG5 -5 ; NEG5"
      (list -5))
    (forth-p2-check-stack "hex literal in def" ": X $10 ; X" (list 16))))

(define
  forth-p2-var-tests
  (fn
    ()
    (forth-p2-check-stack "VARIABLE + !, @" "VARIABLE X 42 X ! X @" (list 42))
    (forth-p2-check-stack "uninitialised @ is 0" "VARIABLE Y Y @" (list 0))
    (forth-p2-check-stack
      "two variables"
      "VARIABLE A VARIABLE B 1 A ! 2 B ! A @ B @ +"
      (list 3))
    (forth-p2-check-stack
      "+! increments"
      "VARIABLE X 10 X ! 5 X +! X @"
      (list 15))
    (forth-p2-check-stack
      "+! multiple"
      "VARIABLE X 0 X ! 1 X +! 2 X +! 3 X +! X @"
      (list 6))))

(define
  forth-p2-const-tests
  (fn
    ()
    (forth-p2-check-stack "CONSTANT" "100 CONSTANT C C" (list 100))
    (forth-p2-check-stack
      "CONSTANT used twice"
      "5 CONSTANT FIVE FIVE FIVE *"
      (list 25))
    (forth-p2-check-stack
      "CONSTANT in colon"
      "3 CONSTANT T : TRIPLE T * ; 7 TRIPLE"
      (list 21))))

(define
  forth-p2-value-tests
  (fn
    ()
    (forth-p2-check-stack "VALUE initial" "50 VALUE V V" (list 50))
    (forth-p2-check-stack "TO overwrites" "50 VALUE V 99 TO V V" (list 99))
    (forth-p2-check-stack "TO twice" "1 VALUE V 2 TO V 3 TO V V" (list 3))
    (forth-p2-check-stack "VALUE in arithmetic" "7 VALUE V V 3 +" (list 10))))

(define
  forth-p2-io-tests
  (fn
    ()
    (forth-p2-check-output
      "colon prints"
      ": HELLO 72 EMIT 73 EMIT ; HELLO"
      "HI")
    (forth-p2-check-output "colon CR" ": LINE 42 . CR ; LINE" "42 \n")))

(define
  forth-p2-mode-tests
  (fn
    ()
    (forth-p2-check-stack "empty colon body" ": NOP ; 5 NOP" (list 5))
    (forth-p2-check-stack
      "colon using DUP"
      ": TWICE DUP ; 9 TWICE"
      (list 9 9))
    (forth-p2-check-stack "IMMEDIATE NOP" ": X ; X" (list))))

(define
  forth-p2-run-all
  (fn
    ()
    (set! forth-p2-passed 0)
    (set! forth-p2-failed 0)
    (set! forth-p2-failures (list))
    (forth-p2-colon-tests)
    (forth-p2-var-tests)
    (forth-p2-const-tests)
    (forth-p2-value-tests)
    (forth-p2-io-tests)
    (forth-p2-mode-tests)
    (dict
      "passed"
      forth-p2-passed
      "failed"
      forth-p2-failed
      "failures"
      forth-p2-failures)))