giles
1c975f229d
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
165 lines
3.5 KiB
Plaintext
165 lines
3.5 KiB
Plaintext
;; Phase 4 — strings + more Core.
|
|
;; Uses the byte-memory model on state ("mem" dict + "here" cursor).
|
|
|
|
(define forth-p4-passed 0)
|
|
(define forth-p4-failed 0)
|
|
(define forth-p4-failures (list))
|
|
|
|
(define
|
|
forth-p4-assert
|
|
(fn
|
|
(label expected actual)
|
|
(if
|
|
(= expected actual)
|
|
(set! forth-p4-passed (+ forth-p4-passed 1))
|
|
(begin
|
|
(set! forth-p4-failed (+ forth-p4-failed 1))
|
|
(set!
|
|
forth-p4-failures
|
|
(concat
|
|
forth-p4-failures
|
|
(list
|
|
(str label ": expected " (str expected) " got " (str actual)))))))))
|
|
|
|
(define
|
|
forth-p4-check-output
|
|
(fn
|
|
(label src expected)
|
|
(let ((r (forth-run src))) (forth-p4-assert label expected (nth r 1)))))
|
|
|
|
(define
|
|
forth-p4-check-stack-size
|
|
(fn
|
|
(label src expected-n)
|
|
(let
|
|
((r (forth-run src)))
|
|
(forth-p4-assert label expected-n (len (nth r 2))))))
|
|
|
|
(define
|
|
forth-p4-check-top
|
|
(fn
|
|
(label src expected)
|
|
(let
|
|
((r (forth-run src)))
|
|
(let
|
|
((stk (nth r 2)))
|
|
(forth-p4-assert label expected (nth stk (- (len stk) 1)))))))
|
|
|
|
(define
|
|
forth-p4-check-typed
|
|
(fn
|
|
(label src expected)
|
|
(forth-p4-check-output label (str src " TYPE") expected)))
|
|
|
|
(define
|
|
forth-p4-string-tests
|
|
(fn
|
|
()
|
|
(forth-p4-check-typed
|
|
"S\" + TYPE — hello"
|
|
"S\" HELLO\""
|
|
"HELLO")
|
|
(forth-p4-check-typed
|
|
"S\" + TYPE — two words"
|
|
"S\" HELLO WORLD\""
|
|
"HELLO WORLD")
|
|
(forth-p4-check-typed
|
|
"S\" + TYPE — empty"
|
|
"S\" \""
|
|
"")
|
|
(forth-p4-check-typed
|
|
"S\" + TYPE — single char"
|
|
"S\" X\""
|
|
"X")
|
|
(forth-p4-check-stack-size
|
|
"S\" pushes (addr len)"
|
|
"S\" HI\""
|
|
2)
|
|
(forth-p4-check-top
|
|
"S\" length is correct"
|
|
"S\" HELLO\""
|
|
5)
|
|
(forth-p4-check-output
|
|
".\" prints at interpret time"
|
|
".\" HELLO\""
|
|
"HELLO")
|
|
(forth-p4-check-output
|
|
".\" in colon def"
|
|
": GREET .\" HI \" ; GREET GREET"
|
|
"HI HI ")))
|
|
|
|
(define
|
|
forth-p4-count-tests
|
|
(fn
|
|
()
|
|
(forth-p4-check-typed
|
|
"C\" + COUNT + TYPE"
|
|
"C\" ABC\" COUNT"
|
|
"ABC")
|
|
(forth-p4-check-typed
|
|
"C\" then COUNT leaves right len"
|
|
"C\" HI THERE\" COUNT"
|
|
"HI THERE")))
|
|
|
|
(define
|
|
forth-p4-fill-tests
|
|
(fn
|
|
()
|
|
(forth-p4-check-typed
|
|
"FILL overwrites prefix bytes"
|
|
"S\" ABCDE\" 2DUP DROP 3 65 FILL"
|
|
"AAADE")
|
|
(forth-p4-check-typed
|
|
"BLANK sets spaces"
|
|
"S\" XYZAB\" 2DUP DROP 3 BLANK"
|
|
" AB")))
|
|
|
|
(define
|
|
forth-p4-cmove-tests
|
|
(fn
|
|
()
|
|
(forth-p4-check-output
|
|
"CMOVE copies HELLO forward"
|
|
": MKH 72 0 C! 69 1 C! 76 2 C! 76 3 C! 79 4 C! ;
|
|
: T MKH 0 10 5 CMOVE 10 5 TYPE ; T"
|
|
"HELLO")
|
|
(forth-p4-check-output
|
|
"CMOVE> copies overlapping backward"
|
|
": MKA 65 0 C! 66 1 C! 67 2 C! ;
|
|
: T MKA 0 1 2 CMOVE> 0 3 TYPE ; T"
|
|
"AAB")
|
|
(forth-p4-check-output
|
|
"MOVE picks direction for overlap"
|
|
": MKA 65 0 C! 66 1 C! 67 2 C! ;
|
|
: T MKA 0 1 2 MOVE 0 3 TYPE ; T"
|
|
"AAB")))
|
|
|
|
(define
|
|
forth-p4-charplus-tests
|
|
(fn
|
|
()
|
|
(forth-p4-check-top
|
|
"CHAR+ increments"
|
|
"5 CHAR+"
|
|
6)))
|
|
|
|
(define
|
|
forth-p4-run-all
|
|
(fn
|
|
()
|
|
(set! forth-p4-passed 0)
|
|
(set! forth-p4-failed 0)
|
|
(set! forth-p4-failures (list))
|
|
(forth-p4-string-tests)
|
|
(forth-p4-count-tests)
|
|
(forth-p4-fill-tests)
|
|
(forth-p4-cmove-tests)
|
|
(forth-p4-charplus-tests)
|
|
(dict
|
|
"passed"
|
|
forth-p4-passed
|
|
"failed"
|
|
forth-p4-failed
|
|
"failures"
|
|
forth-p4-failures)))
|