;; Phase 5 — Core Extension + memory primitives.

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

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

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

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

(define
  forth-p5-create-tests
  (fn
    ()
    (forth-p5-check-top
      "CREATE pushes HERE-at-creation"
      "HERE CREATE FOO FOO ="
      -1)
    (forth-p5-check-top
      "CREATE + ALLOT advances HERE"
      "HERE 5 ALLOT HERE SWAP -"
      5)
    (forth-p5-check-top
      "CREATE + , stores cell"
      "CREATE FOO 42 , FOO @"
      42)
    (forth-p5-check-stack
      "CREATE multiple ,"
      "CREATE TBL 1 , 2 , 3 , TBL @ TBL CELL+ @ TBL CELL+ CELL+ @"
      (list 1 2 3))
    (forth-p5-check-top
      "C, stores byte"
      "CREATE B 65 C, 66 C, B C@"
      65)))

(define
  forth-p5-unsigned-tests
  (fn
    ()
    (forth-p5-check-top "1 2 U<" "1 2 U<" -1)
    (forth-p5-check-top "2 1 U<" "2 1 U<" 0)
    (forth-p5-check-top "0 1 U<" "0 1 U<" -1)
    (forth-p5-check-top "-1 1 U< (since -1 unsigned is huge)" "-1 1 U<" 0)
    (forth-p5-check-top "1 -1 U<" "1 -1 U<" -1)
    (forth-p5-check-top "1 2 U>" "1 2 U>" 0)
    (forth-p5-check-top "-1 1 U>" "-1 1 U>" -1)))

(define
  forth-p5-2bang-tests
  (fn
    ()
    (forth-p5-check-stack
      "2! / 2@"
      "CREATE X 0 , 0 , 11 22 X 2! X 2@"
      (list 11 22))))

(define
  forth-p5-mixed-tests
  (fn
    ()
    (forth-p5-check-stack "S>D positive" "5 S>D" (list 5 0))
    (forth-p5-check-stack "S>D negative" "-5 S>D" (list -5 -1))
    (forth-p5-check-stack "S>D zero" "0 S>D" (list 0 0))
    (forth-p5-check-top "D>S keeps low" "5 0 D>S" 5)
    (forth-p5-check-stack "M* small positive" "3 4 M*" (list 12 0))
    (forth-p5-check-stack "M* negative" "-3 4 M*" (list -12 -1))
    (forth-p5-check-stack
      "M* negative * negative"
      "-3 -4 M*"
      (list 12 0))
    (forth-p5-check-stack "UM* small" "3 4 UM*" (list 12 0))
    (forth-p5-check-stack
      "UM/MOD: 100 0 / 5"
      "100 0 5 UM/MOD"
      (list 0 20))
    (forth-p5-check-stack
      "FM/MOD: -7 / 2 floored"
      "-7 -1 2 FM/MOD"
      (list 1 -4))
    (forth-p5-check-stack
      "SM/REM: -7 / 2 truncated"
      "-7 -1 2 SM/REM"
      (list -1 -3))
    (forth-p5-check-top "*/ truncated" "7 11 13 */" 5)
    (forth-p5-check-stack "*/MOD" "7 11 13 */MOD" (list 12 5))))

(define
  forth-p5-run-all
  (fn
    ()
    (set! forth-p5-passed 0)
    (set! forth-p5-failed 0)
    (set! forth-p5-failures (list))
    (forth-p5-create-tests)
    (forth-p5-unsigned-tests)
    (forth-p5-2bang-tests)
    (forth-p5-mixed-tests)
    (dict
      "passed"
      forth-p5-passed
      "failed"
      forth-p5-failed
      "failures"
      forth-p5-failures)))