;; 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-double-tests
  (fn
    ()
    (forth-p5-check-stack "D+ small" "5 0 7 0 D+" (list 12 0))
    (forth-p5-check-stack "D+ negative" "-5 -1 -3 -1 D+" (list -8 -1))
    (forth-p5-check-stack "D- small" "10 0 3 0 D-" (list 7 0))
    (forth-p5-check-stack "DNEGATE positive" "5 0 DNEGATE" (list -5 -1))
    (forth-p5-check-stack "DNEGATE negative" "-5 -1 DNEGATE" (list 5 0))
    (forth-p5-check-stack "DABS negative" "-7 -1 DABS" (list 7 0))
    (forth-p5-check-stack "DABS positive" "7 0 DABS" (list 7 0))
    (forth-p5-check-top "D= equal" "5 0 5 0 D=" -1)
    (forth-p5-check-top "D= unequal lo" "5 0 7 0 D=" 0)
    (forth-p5-check-top "D= unequal hi" "5 0 5 1 D=" 0)
    (forth-p5-check-top "D< lt" "5 0 7 0 D<" -1)
    (forth-p5-check-top "D< gt" "7 0 5 0 D<" 0)
    (forth-p5-check-top "D0= zero" "0 0 D0=" -1)
    (forth-p5-check-top "D0= nonzero" "5 0 D0=" 0)
    (forth-p5-check-top "D0< neg" "-5 -1 D0<" -1)
    (forth-p5-check-top "D0< pos" "5 0 D0<" 0)
    (forth-p5-check-stack "DMAX" "5 0 7 0 DMAX" (list 7 0))
    (forth-p5-check-stack "DMIN" "5 0 7 0 DMIN" (list 5 0))))

(define
  forth-p5-format-tests
  (fn
    ()
    (forth-p4-check-output-passthrough
      "U. prints with trailing space"
      "123 U."
      "123 ")
    (forth-p4-check-output-passthrough
      "<# #S #> TYPE — decimal"
      "123 0 <# #S #> TYPE"
      "123")
    (forth-p4-check-output-passthrough
      "<# #S #> TYPE — hex"
      "255 HEX 0 <# #S #> TYPE"
      "FF")
    (forth-p4-check-output-passthrough
      "<# # # #> partial"
      "1234 0 <# # # #> TYPE"
      "34")
    (forth-p4-check-output-passthrough
      "SIGN holds minus"
      "<# -1 SIGN -1 SIGN 0 0 #> TYPE"
      "--")
    (forth-p4-check-output-passthrough
      ".R right-justifies"
      "42 5 .R"
      "   42")
    (forth-p4-check-output-passthrough
      ".R negative"
      "-42 5 .R"
      "  -42")
    (forth-p4-check-output-passthrough
      "U.R"
      "42 5 U.R"
      "   42")
    (forth-p4-check-output-passthrough
      "HOLD char"
      "<# 0 0 65 HOLD #> TYPE"
      "A")))

(define
  forth-p5-dict-tests
  (fn
    ()
    (forth-p5-check-top
      "EXECUTE via tick"
      ": INC 1+ ; 9 ' INC EXECUTE"
      10)
    (forth-p5-check-top
      "['] inside def"
      ": DUB 2* ; : APPLY ['] DUB EXECUTE ; 5 APPLY"
      10)
    (forth-p5-check-top
      ">BODY of CREATE word"
      "CREATE C 99 , ' C >BODY @"
      99)
    (forth-p5-check-stack
      "WORD parses next token to counted-string"
      ": A 5 ; BL WORD A COUNT TYPE"
      (list))
    (forth-p5-check-top
      "FIND on known word -> non-zero"
      ": A 5 ; BL WORD A FIND SWAP DROP"
      -1)))

(define
  forth-p5-state-tests
  (fn
    ()
    (forth-p5-check-top
      "STATE @ in interpret mode"
      "STATE @"
      0)
    (forth-p5-check-top
      "STATE @ via IMMEDIATE inside compile"
      ": GT8 STATE @ ; IMMEDIATE : T GT8 LITERAL ; T"
      -1)
    (forth-p5-check-top
      "[ ] LITERAL captures"
      ": SEVEN [ 7 ] LITERAL ; SEVEN"
      7)
    (forth-p5-check-top
      "EVALUATE in interpret mode"
      "S\" 5 7 +\" EVALUATE"
      12)
    (forth-p5-check-top
      "EVALUATE inside def"
      ": A 100 ; : B S\" A\" EVALUATE ; B"
      100)))

(define
  forth-p5-misc-tests
  (fn
    ()
    (forth-p5-check-top "WITHIN inclusive lower" "3 2 10 WITHIN" -1)
    (forth-p5-check-top "WITHIN exclusive upper" "10 2 10 WITHIN" 0)
    (forth-p5-check-top "WITHIN below range" "1 2 10 WITHIN" 0)
    (forth-p5-check-top "WITHIN at lower" "2 2 10 WITHIN" -1)
    (forth-p5-check-top
      "EXIT leaves colon-def early"
      ": F 5 EXIT 99 ; F"
      5)
    (forth-p5-check-stack
      "EXIT in IF branch"
      ": F 5 0 IF DROP 99 EXIT THEN ; F"
      (list 5))
    (forth-p5-check-top
      "UNLOOP + EXIT in DO"
      ": SUM 0 10 0 DO I 5 = IF I UNLOOP EXIT THEN LOOP ; SUM"
      5)))

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

(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)
    (forth-p5-double-tests)
    (forth-p5-format-tests)
    (forth-p5-dict-tests)
    (forth-p5-state-tests)
    (forth-p5-misc-tests)
    (dict
      "passed"
      forth-p5-passed
      "failed"
      forth-p5-failed
      "failures"
      forth-p5-failures)))