simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

test(spec): state, multimethods, protocols — fix reify, get-method, hierarchies

Browse source 
Add spec suites for stateful refs (atoms/volatiles/delays/promises), multimethods
(dispatch + hierarchies), and protocols/types/records. Bugs caught and fixed:
- reify with multiple methods registered only the first (stepped i by 2 over
  one-element specs); now collects every method spec
- get-method/methods/remove-method evaluated their arg to the dispatch fn, but a
  multimethod's methods live on its var — now resolve the var (get-method and
  methods are special forms; remove-method fixed). get-method/methods added.
- no global hierarchy: 2-arg derive modified a throwaway, isa? was hardcoded
  false, parents missing, ancestors/descendants returned arrays (so contains?
  failed), and dispatch ignored derive. Now a global hierarchy backs the 1/2-arg
  derive/isa?/parents/ancestors/descendants (returning sets) and multimethod
  dispatch falls back to it.

Corrected a phase5 port assertion that encoded the old isa? bug.
conformance 218/218, jpm test green.
This commit is contained in:
Yogthos 2026-06-05 00:24:18 -04:00
parent 50d63d896f
commit a24e9bfba0
7 changed files with 174 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

41
src/jolt/core.janet
View file

@ -2226,24 +2226,28 @@
(defn core-derive
[& args]
(case (length args)
2 (let [[tag parent] args] (derive* (make-hierarchy) tag parent))
2 (let [[tag parent] args] (derive* the-global-hierarchy tag parent) nil)
3 (let [[h tag parent] args] (derive* h tag parent))))
(defn core-isa?
[& args]
(case (length args)
1 false
2 false
2 (let [[child parent] args] (isa? the-global-hierarchy child parent))
3 (let [[h child parent] args] (isa? h child parent))))
(defn core-ancestors
[& args]
(case (length args)
1 @[]
2 (let [[h tag] args] (ancestors h tag))))
1 (apply make-phs (ancestors the-global-hierarchy (in args 0)))
2 (let [[h tag] args] (apply make-phs (ancestors h tag)))))
(defn core-descendants
[& args]
(case (length args)
1 @[]
2 (let [[h tag] args] (descendants h tag))))
1 (apply make-phs (descendants the-global-hierarchy (in args 0)))
2 (let [[h tag] args] (apply make-phs (descendants h tag)))))
(defn core-parents
[& args]
(let [[h tag] (if (= 1 (length args)) [the-global-hierarchy (in args 0)] args)
p (get (h :parents) tag)]
(if p (make-phs p) (make-phs))))
(def core-underive underive)
(def core-get-method (fn [mm-var dispatch-val]
(let [methods (get mm-var :jolt/methods)]
@ -2583,17 +2587,23 @@
(def core-extend (fn [& args] nil))
(defn core-reify [proto-sym & impls]
(defn core-reify [& forms]
# forms interleaves protocol-name symbols with method specs (name [args] body);
# collect every method spec (a list), tracking the first protocol for the tag.
(def result @[{:jolt/type :symbol :ns nil :name "do"}])
(def methods @{})
(var proto-sym nil)
(var i 0)
(while (< i (length impls))
(let [method-spec (impls i)]
(def method-name (method-spec 0))
(def arg-vec (method-spec 1))
(def body (tuple/slice method-spec 2))
(put methods (keyword (if (struct? method-name) (method-name :name) method-name)) @{:fn* true :args arg-vec :body body})
(+= i 2)))
(while (< i (length forms))
(def elem (in forms i))
(if (and (struct? elem) (= :symbol (elem :jolt/type)))
(do (when (nil? proto-sym) (set proto-sym elem)) (++ i))
(let [method-name (in elem 0)
arg-vec (in elem 1)
body (tuple/slice elem 2)]
(put methods (keyword (if (struct? method-name) (method-name :name) method-name))
@{:fn* true :args arg-vec :body body})
(++ i))))
(array/push result @[
{:jolt/type :symbol :ns nil :name "make-reified"}
proto-sym
@ -3487,6 +3497,7 @@
"defn-" core-defn-
"derive" core-derive
"isa?" core-isa?
"parents" core-parents
"ancestors" core-ancestors
"descendants" core-descendants
"make-hierarchy" core-make-hierarchy

43
src/jolt/evaluator.janet
View file

@ -29,7 +29,8 @@
(= name "disj") (= name "set?")
(= name "satisfies?")
(= name "protocol-dispatch") (= name "register-method") (= name "make-reified")
(= name "prefer-method") (= name "remove-method") (= name "remove-all-methods")))
(= name "prefer-method") (= name "remove-method") (= name "remove-all-methods")
(= name "get-method") (= name "methods")))
(var eval-form nil)
@ -1045,14 +1046,14 @@
method (get methods dv)]
(if method
(apply method args)
# hierarchy-based match
(let [found (if hierarchy
(do (var f nil) (var i 0)
(let [ks (keys methods)]
(while (and (nil? f) (< i (length ks)))
(if (isa? hierarchy dv (ks i)) (set f (get methods (ks i))))
(++ i))) f)
nil)]
# hierarchy-based match (explicit :hierarchy or
# the global hierarchy from derive)
(let [h (or hierarchy the-global-hierarchy)
found (do (var f nil) (var i 0)
(let [ks (keys methods)]
(while (and (nil? f) (< i (length ks)))
(if (isa? h dv (in ks i)) (set f (get methods (in ks i))))
(++ i))) f)]
(if found (apply found args)
# fall back to the method registered under the default key
(let [dm (get methods default-key)]
@ -1103,11 +1104,29 @@
(do (put mm-var :jolt/prefers @{}) (mm-var :jolt/prefers)))]
(put prefs dispatch-val-a dispatch-val-b)
mm-var)
"remove-method" (let [mm-var (eval-form ctx bindings (in form 1))
# A multimethod's methods live on its VAR, but the value is the dispatch fn;
# so resolve the var from the symbol rather than evaluating it.
"get-method" (let [mm-arg (in form 1)
mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type)))
(resolve-var ctx bindings mm-arg)
(eval-form ctx bindings mm-arg))
dispatch-val (eval-form ctx bindings (in form 2))]
(when mm-var
(let [methods (get mm-var :jolt/methods)]
(or (get methods dispatch-val) (get methods :default)))))
"methods" (let [mm-arg (in form 1)
mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type)))
(resolve-var ctx bindings mm-arg)
(eval-form ctx bindings mm-arg))]
(and mm-var (get mm-var :jolt/methods)))
"remove-method" (let [mm-arg (in form 1)
mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type)))
(resolve-var ctx bindings mm-arg)
(eval-form ctx bindings mm-arg))
dispatch-val (eval-form ctx bindings (in form 2))]
(if mm-var
(when mm-var
(let [methods (get mm-var :jolt/methods)]
(put methods dispatch-val nil)))
(when methods (put methods dispatch-val nil))))
mm-var)
"remove-all-methods" (let [mm-var (eval-form ctx bindings (in form 1))]
(if mm-var

4
src/jolt/types.janet
View file

@ -148,6 +148,10 @@
[]
{:parents @{} :descendants @{} :ancestors @{}})
# The global hierarchy used by the 1/2-arg derive/isa?/parents/ancestors/
# descendants and by multimethod dispatch when no explicit hierarchy is given.
(def the-global-hierarchy (make-hierarchy))
(defn derive*
"Add a parent relationship to a hierarchy."
[h tag parent]