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

Phase 5: Multimethods + Hierarchy system

Browse source 
- types.janet: make-hierarchy, derive*, ancestors, descendants, isa?, underive
- evaluator.janet: defmulti extended with :default and :hierarchy options
  + keyword dispatch-fns wrapped as (fn [x] (get x kw)) for Janet compat
  + hierarchy-based dispatch walks isa? chain when no direct match
- core.janet: real derive, isa?, ancestors, descendants implementations
  replacing stubs; core-remove-method, core-remove-all-methods,
  core-prefer-method added; new core-bindings entries
- 5 test sections (22-26): hierarchy ops, basic dispatch, :default,
  hierarchy dispatch, remove-method — all pass
- 317 tests, 0 failures
This commit is contained in:
Yogthos 2026-06-02 21:30:38 -04:00
parent fb66851e06
commit a1bfd55b38
9 changed files with 329 additions and 112 deletions
Download patch file Download diff file Expand all files Collapse all files

41
src/jolt/core.janet
View file

@ -857,10 +857,38 @@
@[{:jolt/type :symbol :ns nil :name "def"} fn-name fn-form])))
# Hierarchy stubs for sci bootstrap
(def core-derive (fn [& args] nil))
(def core-isa? (fn [& args] false))
(def core-ancestors (fn [& args] @[]))
(def core-descendants (fn [& args] @[]))
(def core-make-hierarchy make-hierarchy)
(defn core-derive
[& args]
(case (length args)
2 (let [[tag parent] args] (derive* (make-hierarchy) tag parent))
3 (let [[h tag parent] args] (derive* h tag parent))))
(defn core-isa?
[& args]
(case (length args)
1 false
2 false
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))))
(defn core-descendants
[& args]
(case (length args)
1 @[]
2 (let [[h tag] args] (descendants h tag))))
(def core-underive underive)
(def core-remove-method (fn [mm-var dispatch-val]
(let [methods (get mm-var :jolt/methods)]
(put methods dispatch-val nil) mm-var)))
(def core-remove-all-methods (fn [mm-var]
(put mm-var :jolt/methods @{}) mm-var))
(defn core-prefer-method [mm-var dispatch-val-a dispatch-val-b]
(let [prefs (or (get mm-var :jolt/prefers)
(do (put mm-var :jolt/prefers @{}) (mm-var :jolt/prefers)))]
(put prefs dispatch-val-a dispatch-val-b) mm-var))
# Java interop stubs
(def core-Object (fn [] (struct ;[:jolt/type :jolt/java-object])))
@ -1145,6 +1173,11 @@
"isa?" core-isa?
"ancestors" core-ancestors
"descendants" core-descendants
"make-hierarchy" core-make-hierarchy
"underive" core-underive
"remove-method" core-remove-method
"remove-all-methods" core-remove-all-methods
"prefer-method" core-prefer-method
"Object" core-Object
"declare" core-declare
"fn" core-fn

53
src/jolt/evaluator.janet
View file

@ -620,19 +620,50 @@
"Object" true
false)))
"defmulti" (let [name-sym (in form 1)
dispatch-fn (eval-form ctx bindings (in form 2))
ns (ctx-find-ns ctx (ctx-current-ns ctx))
methods @{}
mm-fn (fn [& args]
(let [dv (apply dispatch-fn args)
method (get methods dv)]
(if method
(apply method args)
(error (string "No method in multimethod "
(name-sym :name) " for dispatch value: "
dv)))))]
dispatch-fn (do
(def raw (eval-form ctx bindings (in form 2)))
(if (keyword? raw)
(fn [x] (get x raw))
raw))
# Parse options: :default val and :hierarchy h
opts (tuple/slice form 3)
default-val (do
(var dv nil) (var i 0)
(while (< i (length opts))
(if (= :default (in opts i))
(do (set dv (in opts (+ i 1))) (set i (length opts)))
(+= i 2))) dv)
hierarchy (do
(var h nil) (var i 0)
(while (< i (length opts))
(if (= :hierarchy (in opts i))
(do (set h (eval-form ctx bindings (in opts (+ i 1)))) (set i (length opts)))
(+= i 2))) h)
ns (ctx-find-ns ctx (ctx-current-ns ctx))
methods @{}
mm-fn (fn [& args]
(let [dv (apply dispatch-fn args)
method (get methods dv)]
(if method
(apply method args)
(if hierarchy
(let [found (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)]
(if found (apply found args)
(if (not (nil? default-val)) default-val
(error (string "No method in multimethod "
(name-sym :name) " for dispatch value: " dv)))))
(if (not (nil? default-val)) default-val
(error (string "No method in multimethod "
(name-sym :name) " for dispatch value: " dv)))))))]
(def v (ns-intern ns (name-sym :name) mm-fn))
(put v :jolt/methods methods)
(when default-val (put v :jolt/default default-val))
(when hierarchy (put v :jolt/hierarchy hierarchy))
(var-get v))
"defmethod" (let [mm-sym (in form 1)
dispatch-val (eval-form ctx bindings (in form 2))

51
src/jolt/types.janet
View file

@ -125,6 +125,57 @@
(put v :meta meta)
meta)
(defn make-hierarchy
"Create a new empty hierarchy for multimethod dispatch."
[]
{:parents @{} :descendants @{} :ancestors @{}})
(defn derive*
"Add a parent relationship to a hierarchy."
[h tag parent]
(put (h :parents) tag parent)
(let [d (get (h :descendants) parent)]
(if d (array/push d tag) (put (h :descendants) parent @[tag])))
(let [a (get (h :ancestors) tag)]
(if a (array/push a parent) (put (h :ancestors) tag @[parent])))
h)
(defn- ancestors*
"Internal: get all ancestors of a tag via iterative graph walk."
[h tag visited]
(var stack @[tag])
(while (> (length stack) 0)
(let [t (array/pop stack)]
(when (not (get visited t))
(put visited t true)
(let [p (get (h :parents) t)]
(when (and p (not= p t))
(array/push stack p))))))
visited)
(defn ancestors
"Return a set of ancestors for a tag in the given hierarchy."
[h tag]
(let [a (get (h :ancestors) tag)] (if a a @[])))
(defn descendants
"Return the descendants of a tag in the given hierarchy."
[h tag]
(let [d (get (h :descendants) tag)] (if d d @[])))
(defn isa?
"Check if child is derived from parent in the given hierarchy."
[h child parent]
(if (= child parent) true
(let [p (get (h :parents) child)]
(if p (isa? h p parent) false))))
(defn underive
"Remove a parent relationship from a hierarchy."
[h tag parent]
(put (h :parents) tag nil)
h)
(defn with-meta
"Return a new var with updated metadata. The original var is unchanged."
[v meta]