Phase 8: Protocol System — defprotocol, extend-type, extend-protocol, satisfies?
- types.janet: type-registry, register-protocol-method, find-protocol-method, type-satisfies? - core.janet: rewritten protocol macros (defprotocol, extend-type, extend-protocol, reify) Protocol value stores :jolt/type :jolt/protocol with :methods map Method dispatch fns use fn* [this & rest-args] → protocol-dispatch special form - evaluator.janet: protocol-dispatch, register-method, make-reified special forms satisfies? special form with type registry lookup special-symbol? entries for all 3 protocol ops + satisfies? - 4 test sections (35-38): defprotocol, extend-type, extend-protocol, satisfies? extend-type: basic dispatch works (42 constant), .-field accessor needs further debug satisfies?: fully functional with type registry - 315 ok, 2 fail (pre-existing, unchanged)
This commit is contained in:
Yogthos
parent
09c4cb2242
commit
053ed4f790
11 changed files with 463 additions and 134 deletions
|
|
@ -1033,32 +1033,99 @@
|
|||
(each b body (array/push result b))
|
||||
result)
|
||||
|
||||
# Protocol stubs — defined in sci.impl.protocols, needed in clojure.core
|
||||
# defprotocol must be a macro to avoid evaluating its args
|
||||
# Protocol implementation — methods dispatch via type registry
|
||||
(defn core-defprotocol [protocol-name & sigs]
|
||||
# Emit (do (def protocol-name {}) (def method1 fn) (def method2 fn) ...)
|
||||
(def result @[])
|
||||
(array/push result {:jolt/type :symbol :ns nil :name "do"})
|
||||
# First (def protocol-name {})
|
||||
(def d @[])
|
||||
(array/push d {:jolt/type :symbol :ns nil :name "def"})
|
||||
(array/push d protocol-name)
|
||||
(array/push d @{})
|
||||
(array/push result d)
|
||||
# Then (def method-name (fn [& args] nil)) for each sig
|
||||
(def methods @{})
|
||||
(each sig sigs
|
||||
(def method-sym (first sig))
|
||||
(def d @[])
|
||||
(array/push d {:jolt/type :symbol :ns nil :name "def"})
|
||||
(array/push d method-sym)
|
||||
(array/push d (fn [& args] nil))
|
||||
(array/push result d))
|
||||
(def method-name (first sig))
|
||||
(def arglists (tuple/slice sig 1))
|
||||
(put methods (keyword (if (struct? method-name) (method-name :name) method-name)) {:name method-name :arglists arglists}))
|
||||
(def proto-def @[])
|
||||
(array/push proto-def {:jolt/type :symbol :ns nil :name "def"})
|
||||
(array/push proto-def protocol-name)
|
||||
(array/push proto-def @{:jolt/type :jolt/protocol
|
||||
:name {:jolt/type :symbol :ns nil :name (protocol-name :name)}
|
||||
:methods methods})
|
||||
(array/push result proto-def)
|
||||
(each sig sigs
|
||||
(def method-name (first sig))
|
||||
(def method-def @[])
|
||||
(array/push method-def {:jolt/type :symbol :ns nil :name "def"})
|
||||
(array/push method-def method-name)
|
||||
(def fn-form @[])
|
||||
(array/push fn-form {:jolt/type :symbol :ns nil :name "fn*"})
|
||||
(array/push fn-form @[{:jolt/type :symbol :ns nil :name "this"} {:jolt/type :symbol :ns nil :name "&"} {:jolt/type :symbol :ns nil :name "rest-args"}])
|
||||
(array/push fn-form @[
|
||||
{:jolt/type :symbol :ns nil :name "protocol-dispatch"}
|
||||
{:jolt/type :symbol :ns nil :name "quote"} protocol-name
|
||||
{:jolt/type :symbol :ns nil :name "quote"} method-name
|
||||
{:jolt/type :symbol :ns nil :name "this"}
|
||||
{:jolt/type :symbol :ns nil :name "rest-args"}])
|
||||
(array/push method-def fn-form)
|
||||
(array/push result method-def))
|
||||
result)
|
||||
(def core-extend-type (fn [& args] nil))
|
||||
(defn core-extend-protocol [& args] @[{:jolt/type :symbol :ns nil :name "do"}])
|
||||
|
||||
(defn core-extend-type [type-sym proto-sym & impls]
|
||||
(def result @[{:jolt/type :symbol :ns nil :name "do"}])
|
||||
(each method-spec impls
|
||||
(def method-name (method-spec 0))
|
||||
(def arg-vec (method-spec 1))
|
||||
(def body (tuple/slice method-spec 2))
|
||||
(def fn-form @[{:jolt/type :symbol :ns nil :name "fn*"} arg-vec ;body])
|
||||
(array/push result @[
|
||||
{:jolt/type :symbol :ns nil :name "register-method"}
|
||||
{:jolt/type :symbol :ns nil :name "quote"} type-sym
|
||||
{:jolt/type :symbol :ns nil :name "quote"} proto-sym
|
||||
{:jolt/type :symbol :ns nil :name "quote"} method-name
|
||||
fn-form]))
|
||||
result)
|
||||
|
||||
(defn core-extend-protocol [proto-sym & type-impls]
|
||||
(def result @[{:jolt/type :symbol :ns nil :name "do"}])
|
||||
(var i 0)
|
||||
(while (< i (length type-impls))
|
||||
(let [type-sym (type-impls i)
|
||||
impls (type-impls (+ i 1))]
|
||||
(var j 0)
|
||||
(while (< j (length impls))
|
||||
(let [method-spec (impls j)]
|
||||
(def method-name (method-spec 0))
|
||||
(def arg-vec (method-spec 1))
|
||||
(def body (tuple/slice method-spec 2))
|
||||
(def fn-form @[{:jolt/type :symbol :ns nil :name "fn*"} arg-vec ;body])
|
||||
(array/push result @[
|
||||
{:jolt/type :symbol :ns nil :name "register-method"}
|
||||
{:jolt/type :symbol :ns nil :name "quote"} type-sym
|
||||
{:jolt/type :symbol :ns nil :name "quote"} proto-sym
|
||||
{:jolt/type :symbol :ns nil :name "quote"} method-name
|
||||
fn-form]))
|
||||
(+= j 2)))
|
||||
(+= i 2))
|
||||
result)
|
||||
|
||||
(def core-extend (fn [& args] nil))
|
||||
(def core-reify (fn [& args] nil))
|
||||
(def core-satisfies? (fn [& args] nil))
|
||||
|
||||
(defn core-reify [proto-sym & impls]
|
||||
(def result @[{:jolt/type :symbol :ns nil :name "do"}])
|
||||
(def methods @{})
|
||||
(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 method-name) @{:fn* true :args arg-vec :body body})
|
||||
(+= i 2)))
|
||||
(array/push result @[
|
||||
{:jolt/type :symbol :ns nil :name "make-reified"}
|
||||
{:jolt/type :symbol :ns nil :name "quote"} proto-sym
|
||||
{:jolt/type :symbol :ns nil :name "quote"} methods])
|
||||
result)
|
||||
|
||||
(def core-satisfies? (fn [proto-sym obj] false))
|
||||
|
||||
(def core-extends? (fn [& args] false))
|
||||
(def core-implements? (fn [& args] false))
|
||||
(def core-type->str (fn [& args] ""))
|
||||
|
|
|
|||
|
|
@ -20,7 +20,9 @@
|
|||
(= name "var-get") (= name "var-set") (= name "var?")
|
||||
(= name "alter-var-root") (= name "find-var") (= name "intern")
|
||||
(= name "alter-meta!") (= name "reset-meta!")
|
||||
(= name "disj") (= name "set?")))
|
||||
(= name "disj") (= name "set?")
|
||||
(= name "satisfies?")
|
||||
(= name "protocol-dispatch") (= name "register-method") (= name "make-reified")))
|
||||
|
||||
(var eval-form nil)
|
||||
|
||||
|
|
@ -610,6 +612,59 @@
|
|||
(apply phs-disj s ks)
|
||||
(error "disj expects a set")))
|
||||
"set?" (set? (eval-form ctx bindings (in form 1)))
|
||||
"protocol-dispatch" (let [proto-sym (in form 1)
|
||||
method-sym (in form 2)
|
||||
obj (eval-form ctx bindings (in form 3))
|
||||
rest-args (eval-form ctx bindings (in form 4))
|
||||
type-tag (if (and (table? obj) (get obj :jolt/deftype))
|
||||
(get obj :jolt/deftype)
|
||||
(if (get obj :jolt/protocol-methods)
|
||||
(get obj :jolt/deftype)))
|
||||
proto-name (proto-sym :name)
|
||||
method-name (method-sym :name)]
|
||||
(if (and (table? obj) (get obj :jolt/protocol-methods))
|
||||
(let [reified-fns (get obj :jolt/protocol-methods)
|
||||
fn (get reified-fns (keyword method-name))]
|
||||
(if fn (apply fn obj rest-args)
|
||||
(error (string "No reified method " method-name " for " type-tag))))
|
||||
(if type-tag
|
||||
(let [fn (find-protocol-method ctx type-tag proto-name method-name)]
|
||||
(if fn (apply fn obj rest-args)
|
||||
(error (string "No method " method-name " in " proto-name " for " type-tag))))
|
||||
(error (string "No dispatch for " method-name " on " (type obj))))))
|
||||
"register-method" (let [type-sym (in form 1)
|
||||
proto-sym (in form 2)
|
||||
method-sym (in form 3)
|
||||
fn (eval-form ctx bindings (in form 4))
|
||||
ns-name (ctx-current-ns ctx)
|
||||
type-name (type-sym :name)
|
||||
type-tag (string ns-name "." type-name)
|
||||
proto-name (proto-sym :name)
|
||||
method-name (method-sym :name)]
|
||||
(register-protocol-method ctx type-tag proto-name method-name fn))
|
||||
"make-reified" (let [proto-sym (in form 1)
|
||||
methods-map (eval-form ctx bindings (in form 2))
|
||||
proto-name (proto-sym :name)
|
||||
reified-tag (string "reified-" proto-name)]
|
||||
(def obj @{:jolt/deftype reified-tag :jolt/protocol-methods @{}})
|
||||
(loop [[k v] :pairs methods-map]
|
||||
(let [fn-value (if (and (table? v) (get v :fn*))
|
||||
(let [args-vec (get v :args)
|
||||
body-forms (get v :body)]
|
||||
(apply (eval-form ctx @{}
|
||||
@[{:jolt/type :symbol :ns nil :name "fn*"} args-vec ;body-forms]) []))
|
||||
v)]
|
||||
(put (obj :jolt/protocol-methods) k fn-value)))
|
||||
obj)
|
||||
"satisfies?" (let [proto-sym (eval-form ctx bindings (in form 1))
|
||||
obj (eval-form ctx bindings (in form 2))
|
||||
type-tag (if (and (table? obj) (get obj :jolt/deftype))
|
||||
(get obj :jolt/deftype)
|
||||
(if (get obj :jolt/protocol-methods)
|
||||
(get obj :jolt/deftype)))]
|
||||
(if type-tag
|
||||
(type-satisfies? ctx type-tag (proto-sym :name))
|
||||
false))
|
||||
"locking" (eval-form ctx bindings (in form 2))
|
||||
"instance?" (let [type-sym (in form 1)
|
||||
val (eval-form ctx bindings (in form 2))]
|
||||
|
|
|
|||
|
|
@ -314,6 +314,7 @@
|
|||
:current-ns "user"
|
||||
:compile? compile?
|
||||
:compiled-cache @{}
|
||||
:type-registry @{}
|
||||
:data-readers (let [dr @{}]
|
||||
(put dr (keyword "#inst") (fn [s] s))
|
||||
(put dr (keyword "#uuid") (fn [s] s))
|
||||
|
|
@ -406,3 +407,35 @@
|
|||
(if v v
|
||||
(let [core-ns (ctx-find-ns ctx "clojure.core")]
|
||||
(ns-find core-ns name)))))))
|
||||
|
||||
|
||||
# ============================================================
|
||||
# Protocol type registry
|
||||
# ============================================================
|
||||
|
||||
(defn register-protocol-method
|
||||
"Register a protocol method implementation for a type."
|
||||
[ctx type-tag protocol-name method-name fn]
|
||||
(let [registry (get (ctx :env) :type-registry)
|
||||
type-impls (or (get registry type-tag)
|
||||
(do (put registry type-tag @{}) (get registry type-tag)))
|
||||
proto-impls (or (get type-impls protocol-name)
|
||||
(do (put type-impls protocol-name @{}) (get type-impls protocol-name)))]
|
||||
(put proto-impls method-name fn)))
|
||||
|
||||
(defn find-protocol-method
|
||||
"Find a protocol method implementation for a type."
|
||||
[ctx type-tag protocol-name method-name]
|
||||
(let [registry (get (ctx :env) :type-registry)
|
||||
type-impls (get registry type-tag)]
|
||||
(when type-impls
|
||||
(let [proto-impls (get type-impls protocol-name)]
|
||||
(when proto-impls
|
||||
(get proto-impls method-name))))))
|
||||
|
||||
(defn type-satisfies?
|
||||
"Check if a type satisfies a protocol."
|
||||
[ctx type-tag protocol-name]
|
||||
(let [registry (get (ctx :env) :type-registry)
|
||||
type-impls (get registry type-tag)]
|
||||
(if (and type-impls (get type-impls protocol-name)) true false)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue