giles
0e509af0a2
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
136 lines
3.5 KiB
Plaintext
136 lines
3.5 KiB
Plaintext
;; 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)))
|