;; Hayes conformance test runner.
;; Installs T{ -> }T as Forth primitives that snapshot and compare dstack,
;; plus stub TESTING / HEX / DECIMAL so the Hayes Core file can stream
;; through the interpreter without halting on unsupported metadata words.

(define hayes-pass 0)
(define hayes-fail 0)
(define hayes-error 0)
(define hayes-start-depth 0)
(define hayes-actual (list))
(define hayes-actual-set false)
(define hayes-failures (list))
(define hayes-first-error "")

(define
  hayes-reset!
  (fn
    ()
    (set! hayes-pass 0)
    (set! hayes-fail 0)
    (set! hayes-error 0)
    (set! hayes-start-depth 0)
    (set! hayes-actual (list))
    (set! hayes-actual-set false)
    (set! hayes-failures (list))
    (set! hayes-first-error "")))

(define
  hayes-slice
  (fn
    (state base)
    (let
      ((n (- (forth-depth state) base)))
      (if (<= n 0) (list) (take (get state "dstack") n)))))

(define
  hayes-truncate!
  (fn
    (state base)
    (let
      ((n (- (forth-depth state) base)))
      (when (> n 0) (dict-set! state "dstack" (drop (get state "dstack") n))))))

(define
  hayes-install!
  (fn
    (state)
    (forth-def-prim!
      state
      "T{"
      (fn
        (s)
        (set! hayes-start-depth (forth-depth s))
        (set! hayes-actual-set false)
        (set! hayes-actual (list))))
    (forth-def-prim!
      state
      "->"
      (fn
        (s)
        (set! hayes-actual (hayes-slice s hayes-start-depth))
        (set! hayes-actual-set true)
        (hayes-truncate! s hayes-start-depth)))
    (forth-def-prim!
      state
      "}T"
      (fn
        (s)
        (let
          ((expected (hayes-slice s hayes-start-depth)))
          (hayes-truncate! s hayes-start-depth)
          (if
            (and hayes-actual-set (= expected hayes-actual))
            (set! hayes-pass (+ hayes-pass 1))
            (begin
              (set! hayes-fail (+ hayes-fail 1))
              (set!
                hayes-failures
                (concat
                  hayes-failures
                  (list
                    (dict
                      "kind"
                      "fail"
                      "expected"
                      (str expected)
                      "actual"
                      (str hayes-actual))))))))))
    (forth-def-prim! state "TESTING" (fn (s) nil))
    (forth-def-prim! state "HEX" (fn (s) (dict-set! s "base" 16)))
    (forth-def-prim! state "DECIMAL" (fn (s) (dict-set! s "base" 10)))
    state))

(define
  hayes-boot
  (fn () (let ((s (forth-boot))) (hayes-install! s) (hayes-reset!) s)))

;; Run a single preprocessed chunk (string of Forth source) on the shared
;; state. Catch any raised error and move on — the chunk boundary is a
;; safe resume point.
(define
  hayes-run-chunk
  (fn
    (state src)
    (guard
      (err
        ((= 1 1)
          (begin
            (set! hayes-error (+ hayes-error 1))
            (when
              (= (len hayes-first-error) 0)
              (set! hayes-first-error (str err)))
            (dict-set! state "dstack" (list))
            (dict-set! state "rstack" (list))
            (dict-set! state "compiling" false)
            (dict-set! state "current-def" nil)
            (dict-set! state "cstack" (list))
            (dict-set! state "input" (list)))))
      (forth-interpret state src))))

(define
  hayes-summary
  (fn
    ()
    (dict
      "pass"
      hayes-pass
      "fail"
      hayes-fail
      "error"
      hayes-error
      "total"
      (+ (+ hayes-pass hayes-fail) hayes-error)
      "first-error"
      hayes-first-error)))