278 lines
11 KiB
Plaintext
278 lines
11 KiB
Plaintext
;; Erlang runtime tests — scheduler + process-record primitives.
|
|
|
|
(define er-rt-test-count 0)
|
|
(define er-rt-test-pass 0)
|
|
(define er-rt-test-fails (list))
|
|
|
|
(define
|
|
er-rt-test
|
|
(fn
|
|
(name actual expected)
|
|
(set! er-rt-test-count (+ er-rt-test-count 1))
|
|
(if
|
|
(= actual expected)
|
|
(set! er-rt-test-pass (+ er-rt-test-pass 1))
|
|
(append! er-rt-test-fails {:actual actual :expected expected :name name}))))
|
|
|
|
;; ── queue ─────────────────────────────────────────────────────────
|
|
(er-rt-test "queue empty len" (er-q-len (er-q-new)) 0)
|
|
(er-rt-test "queue empty?" (er-q-empty? (er-q-new)) true)
|
|
|
|
(define q1 (er-q-new))
|
|
(er-q-push! q1 "a")
|
|
(er-q-push! q1 "b")
|
|
(er-q-push! q1 "c")
|
|
(er-rt-test "queue push len" (er-q-len q1) 3)
|
|
(er-rt-test "queue empty? after push" (er-q-empty? q1) false)
|
|
(er-rt-test "queue peek" (er-q-peek q1) "a")
|
|
(er-rt-test "queue pop 1" (er-q-pop! q1) "a")
|
|
(er-rt-test "queue pop 2" (er-q-pop! q1) "b")
|
|
(er-rt-test "queue len after pops" (er-q-len q1) 1)
|
|
(er-rt-test "queue pop 3" (er-q-pop! q1) "c")
|
|
(er-rt-test "queue empty again" (er-q-empty? q1) true)
|
|
(er-rt-test "queue pop empty" (er-q-pop! q1) nil)
|
|
|
|
;; Queue FIFO under interleaved push/pop
|
|
(define q2 (er-q-new))
|
|
(er-q-push! q2 1)
|
|
(er-q-push! q2 2)
|
|
(er-q-pop! q2)
|
|
(er-q-push! q2 3)
|
|
(er-rt-test "queue interleave peek" (er-q-peek q2) 2)
|
|
(er-rt-test "queue to-list" (er-q-to-list q2) (list 2 3))
|
|
|
|
;; ── scheduler init ─────────────────────────────────────────────
|
|
(er-sched-init!)
|
|
(er-rt-test "sched process count 0" (er-sched-process-count) 0)
|
|
(er-rt-test "sched runnable count 0" (er-sched-runnable-count) 0)
|
|
(er-rt-test "sched current nil" (er-sched-current-pid) nil)
|
|
|
|
;; ── pid allocation ─────────────────────────────────────────────
|
|
(define pa (er-pid-new!))
|
|
(define pb (er-pid-new!))
|
|
(er-rt-test "pid tag" (get pa :tag) "pid")
|
|
(er-rt-test "pid ids distinct" (= (er-pid-id pa) (er-pid-id pb)) false)
|
|
(er-rt-test "pid? true" (er-pid? pa) true)
|
|
(er-rt-test "pid? false" (er-pid? 42) false)
|
|
(er-rt-test
|
|
"pid-equal same"
|
|
(er-pid-equal? pa (er-mk-pid (er-pid-id pa)))
|
|
true)
|
|
(er-rt-test "pid-equal diff" (er-pid-equal? pa pb) false)
|
|
|
|
;; ── process lifecycle ──────────────────────────────────────────
|
|
(er-sched-init!)
|
|
(define p1 (er-proc-new! {}))
|
|
(define p2 (er-proc-new! {}))
|
|
(er-rt-test "proc count 2" (er-sched-process-count) 2)
|
|
(er-rt-test "runnable count 2" (er-sched-runnable-count) 2)
|
|
(er-rt-test
|
|
"proc state runnable"
|
|
(er-proc-field (get p1 :pid) :state)
|
|
"runnable")
|
|
(er-rt-test
|
|
"proc mailbox empty"
|
|
(er-proc-mailbox-size (get p1 :pid))
|
|
0)
|
|
(er-rt-test
|
|
"proc lookup"
|
|
(er-pid-equal? (get (er-proc-get (get p1 :pid)) :pid) (get p1 :pid))
|
|
true)
|
|
(er-rt-test "proc exists" (er-proc-exists? (get p1 :pid)) true)
|
|
(er-rt-test
|
|
"proc no-such-pid"
|
|
(er-proc-exists? (er-mk-pid 9999))
|
|
false)
|
|
|
|
;; runnable queue dequeue order
|
|
(er-rt-test
|
|
"dequeue first"
|
|
(er-pid-equal? (er-sched-next-runnable!) (get p1 :pid))
|
|
true)
|
|
(er-rt-test
|
|
"dequeue second"
|
|
(er-pid-equal? (er-sched-next-runnable!) (get p2 :pid))
|
|
true)
|
|
(er-rt-test "dequeue empty" (er-sched-next-runnable!) nil)
|
|
|
|
;; current-pid get/set
|
|
(er-sched-set-current! (get p1 :pid))
|
|
(er-rt-test
|
|
"current pid set"
|
|
(er-pid-equal? (er-sched-current-pid) (get p1 :pid))
|
|
true)
|
|
|
|
;; ── mailbox push ──────────────────────────────────────────────
|
|
(er-proc-mailbox-push! (get p1 :pid) {:tag "atom" :name "ping"})
|
|
(er-proc-mailbox-push! (get p1 :pid) 42)
|
|
(er-rt-test "mailbox size 2" (er-proc-mailbox-size (get p1 :pid)) 2)
|
|
|
|
;; ── field update ──────────────────────────────────────────────
|
|
(er-proc-set! (get p1 :pid) :state "waiting")
|
|
(er-rt-test
|
|
"proc state waiting"
|
|
(er-proc-field (get p1 :pid) :state)
|
|
"waiting")
|
|
(er-proc-set! (get p1 :pid) :trap-exit true)
|
|
(er-rt-test
|
|
"proc trap-exit"
|
|
(er-proc-field (get p1 :pid) :trap-exit)
|
|
true)
|
|
|
|
;; ── fresh scheduler ends in clean state ───────────────────────
|
|
(er-sched-init!)
|
|
(er-rt-test
|
|
"sched init resets count"
|
|
(er-sched-process-count)
|
|
0)
|
|
(er-rt-test
|
|
"sched init resets queue"
|
|
(er-sched-runnable-count)
|
|
0)
|
|
(er-rt-test
|
|
"sched init resets current"
|
|
(er-sched-current-pid)
|
|
nil)
|
|
|
|
|
|
|
|
;; ── Phase 7: module-version slots ───────────────────────────────
|
|
(er-modules-reset!)
|
|
|
|
(define er-rt-slot1 (er-mk-module-slot (er-env-new) nil 1))
|
|
(er-rt-test "slot tag" (get er-rt-slot1 :tag) "module")
|
|
(er-rt-test "slot version" (er-module-version er-rt-slot1) 1)
|
|
(er-rt-test "slot old nil" (er-module-old-env er-rt-slot1) nil)
|
|
(er-rt-test "slot current not nil" (= (er-module-current-env er-rt-slot1) nil) false)
|
|
|
|
(erlang-load-module "-module(hr1). a() -> 1.")
|
|
(define er-rt-reg (er-modules-get))
|
|
(er-rt-test "registry has hr1" (dict-has? er-rt-reg "hr1") true)
|
|
(er-rt-test "v1 on first load" (er-module-version (get er-rt-reg "hr1")) 1)
|
|
(er-rt-test "v1 old is nil" (er-module-old-env (get er-rt-reg "hr1")) nil)
|
|
(er-rt-test "v1 current not nil" (= (er-module-current-env (get er-rt-reg "hr1")) nil) false)
|
|
|
|
(define er-rt-env-v1 (er-module-current-env (get er-rt-reg "hr1")))
|
|
(erlang-load-module "-module(hr1). a() -> 2.")
|
|
(er-rt-test "v2 on second load" (er-module-version (get er-rt-reg "hr1")) 2)
|
|
(er-rt-test "v2 old is v1 env" (er-module-old-env (get er-rt-reg "hr1")) er-rt-env-v1)
|
|
(er-rt-test "v2 current is new" (= (er-module-current-env (get er-rt-reg "hr1")) er-rt-env-v1) false)
|
|
|
|
(erlang-load-module "-module(hr1). a() -> 3.")
|
|
(er-rt-test "v3 on third load" (er-module-version (get er-rt-reg "hr1")) 3)
|
|
|
|
(er-modules-reset!)
|
|
(er-rt-test "registry-reset clears" (dict-has? (er-modules-get) "hr1") false)
|
|
|
|
|
|
|
|
|
|
;; ── Phase 8: FFI BIF registry ──────────────────────────────────
|
|
(er-bif-registry-reset!)
|
|
|
|
(er-rt-test "empty registry" (len (er-list-bifs)) 0)
|
|
(er-rt-test "lookup miss" (er-lookup-bif "crypto" "hash" 2) nil)
|
|
|
|
(er-register-bif! "fake" "echo" 1 (fn (vs) (nth vs 0)))
|
|
(er-rt-test "register grows registry" (len (er-list-bifs)) 1)
|
|
|
|
(define er-rt-bif-hit (er-lookup-bif "fake" "echo" 1))
|
|
(er-rt-test "lookup hit module" (get er-rt-bif-hit :module) "fake")
|
|
(er-rt-test "lookup hit name" (get er-rt-bif-hit :name) "echo")
|
|
(er-rt-test "lookup hit arity" (get er-rt-bif-hit :arity) 1)
|
|
(er-rt-test "lookup hit pure?" (get er-rt-bif-hit :pure?) false)
|
|
|
|
(er-rt-test "fn invocable" ((get er-rt-bif-hit :fn) (list 42)) 42)
|
|
|
|
;; Re-register replaces (same key)
|
|
(er-register-bif! "fake" "echo" 1 (fn (vs) "replaced"))
|
|
(er-rt-test "re-register same key, count unchanged" (len (er-list-bifs)) 1)
|
|
(er-rt-test "re-register replaces fn"
|
|
((get (er-lookup-bif "fake" "echo" 1) :fn) (list 99)) "replaced")
|
|
|
|
;; Pure variant
|
|
(er-register-pure-bif! "fake" "pure" 2 (fn (vs) (+ (nth vs 0) (nth vs 1))))
|
|
(er-rt-test "pure registered separately, count 2" (len (er-list-bifs)) 2)
|
|
(er-rt-test "pure flag true"
|
|
(get (er-lookup-bif "fake" "pure" 2) :pure?) true)
|
|
(er-rt-test "pure fn invocable"
|
|
((get (er-lookup-bif "fake" "pure" 2) :fn) (list 7 8)) 15)
|
|
|
|
;; Arity disambiguation: same module+name, different arity = distinct entries
|
|
(er-register-bif! "fake" "echo" 2 (fn (vs) (list (nth vs 0) (nth vs 1))))
|
|
(er-rt-test "arity disambiguation count" (len (er-list-bifs)) 3)
|
|
(er-rt-test "arity-1 lookup still works"
|
|
((get (er-lookup-bif "fake" "echo" 1) :fn) (list 11)) "replaced")
|
|
(er-rt-test "arity-2 lookup independent"
|
|
(len ((get (er-lookup-bif "fake" "echo" 2) :fn) (list 1 2))) 2)
|
|
|
|
;; Reset clears the registry
|
|
(er-bif-registry-reset!)
|
|
(er-rt-test "reset clears" (len (er-list-bifs)) 0)
|
|
(er-rt-test "reset lookup nil" (er-lookup-bif "fake" "echo" 1) nil)
|
|
|
|
|
|
|
|
;; ── Phase 8: term marshalling (er-to-sx / er-of-sx) ─────────────
|
|
|
|
;; er-to-sx: Erlang → SX
|
|
(er-rt-test "to-sx atom" (er-to-sx (er-mk-atom "foo")) (make-symbol "foo"))
|
|
(er-rt-test "to-sx atom is symbol" (type-of (er-to-sx (er-mk-atom "x"))) "symbol")
|
|
(er-rt-test "to-sx nil" (er-to-sx (er-mk-nil)) (list))
|
|
(er-rt-test "to-sx integer passthrough" (er-to-sx 42) 42)
|
|
(er-rt-test "to-sx float passthrough" (er-to-sx 3.14) 3.14)
|
|
(er-rt-test "to-sx boolean passthrough" (er-to-sx true) true)
|
|
(er-rt-test "to-sx binary → string"
|
|
(er-to-sx (er-mk-binary (list 104 105 33))) "hi!")
|
|
(er-rt-test "to-sx cons → list"
|
|
(er-to-sx (er-mk-cons 1 (er-mk-cons 2 (er-mk-cons 3 (er-mk-nil))))) (list 1 2 3))
|
|
(er-rt-test "to-sx tuple → list"
|
|
(er-to-sx (er-mk-tuple (list 1 2 3))) (list 1 2 3))
|
|
(er-rt-test "to-sx nested cons"
|
|
(er-to-sx (er-mk-cons (er-mk-atom "a") (er-mk-cons 7 (er-mk-nil))))
|
|
(list (make-symbol "a") 7))
|
|
|
|
;; er-of-sx: SX → Erlang
|
|
(er-rt-test "of-sx symbol"
|
|
(get (er-of-sx (make-symbol "ok")) :name) "ok")
|
|
(er-rt-test "of-sx symbol is atom"
|
|
(er-atom? (er-of-sx (make-symbol "x"))) true)
|
|
(er-rt-test "of-sx string is binary"
|
|
(er-binary? (er-of-sx "hi")) true)
|
|
(er-rt-test "of-sx string bytes"
|
|
(get (er-of-sx "hi") :bytes) (list 104 105))
|
|
(er-rt-test "of-sx integer passthrough"
|
|
(er-of-sx 42) 42)
|
|
(er-rt-test "of-sx empty list → nil"
|
|
(er-nil? (er-of-sx (list))) true)
|
|
(er-rt-test "of-sx list → cons chain length"
|
|
(er-list-length (er-of-sx (list 1 2 3 4))) 4)
|
|
(er-rt-test "of-sx list head/tail"
|
|
(get (er-of-sx (list 10 20)) :head) 10)
|
|
|
|
;; Round-trips
|
|
(er-rt-test "rtrip integer" (er-to-sx (er-of-sx 99)) 99)
|
|
(er-rt-test "rtrip atom"
|
|
(get (er-of-sx (er-to-sx (er-mk-atom "abc"))) :name) "abc")
|
|
(er-rt-test "rtrip binary bytes"
|
|
(get (er-of-sx (er-to-sx (er-mk-binary (list 1 2 3)))) :bytes) (list 1 2 3))
|
|
(er-rt-test "rtrip cons-of-ints length"
|
|
(er-list-length (er-of-sx (er-to-sx
|
|
(er-mk-cons 1 (er-mk-cons 2 (er-mk-cons 3 (er-mk-nil))))))) 3)
|
|
|
|
;; Tuples don't round-trip exactly (er-to-sx flattens tuples to lists);
|
|
;; documented one-way conversion.
|
|
(er-rt-test "to-sx of tuple loses tag"
|
|
(er-cons? (er-of-sx (er-to-sx (er-mk-tuple (list 1 2 3))))) true)
|
|
|
|
|
|
;; Re-populate built-in BIFs so subsequent test files (ring, ping-pong, etc.)
|
|
;; can call length/spawn/etc. The migration onto the registry means a reset
|
|
;; here would otherwise break the rest of the conformance suite.
|
|
(er-register-builtin-bifs!)
|
|
|
|
|
|
(define
|
|
er-rt-test-summary
|
|
(str "runtime " er-rt-test-pass "/" er-rt-test-count))
|