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