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

test: add features-test.janet (71 assertions mirroring all clojure-features.clj sections + expansions + demo smoke test); fix 3 bugs it caught — for :while ignored, map->Record params (array vs tuple), extend-protocol to host types (Long/String/Number) now dispatches

Browse source
This commit is contained in:
Yogthos 2026-06-04 17:45:31 -04:00
parent 1b37e56df4
commit aeaf1b624c
3 changed files with 201 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

14
src/jolt/core.janet
View file

@ -1646,14 +1646,18 @@
(var i 0)
(while (< i (length bvec))
(def bind (bvec i))
(def coll (bvec (+ i 1)))
(var coll (bvec (+ i 1)))
(def mods @[])
(+= i 2)
(while (and (< i (length bvec)) (keyword? (bvec i)))
(case (bvec i)
:when (do (array/push mods @[{:jolt/type :symbol :ns nil :name "when"} (bvec (+ i 1))]) (+= i 2))
:let (do (array/push mods @[{:jolt/type :symbol :ns nil :name "let"} (bvec (+ i 1))]) (+= i 2))
:while (do (+= i 2))
# :while terminates iteration of this binding's collection
:while (do (set coll @[{:jolt/type :symbol :ns nil :name "take-while"}
@[{:jolt/type :symbol :ns nil :name "fn"} [bind] (bvec (+ i 1))]
coll])
(+= i 2))
(do (+= i 1))))
(array/push groups @[bind coll mods]))
groups)
@ -1998,9 +2002,11 @@
# map-> factory: (def map->TypeName (fn [m] (->TypeName (get m :field1) (get m :field2) ...)))
(def map-call @[{:jolt/type :symbol :ns nil :name arrow-name}])
(each f fields-vec
(array/push map-call @[{:jolt/type :symbol :ns nil :name "core-get"} {:jolt/type :symbol :ns nil :name (string "m")} (keyword (f :name))]))
(array/push map-call @[{:jolt/type :symbol :ns nil :name "get"} {:jolt/type :symbol :ns nil :name (string "m")} (keyword (f :name))]))
(def map-sym {:jolt/type :symbol :ns nil :name map-name})
(def map-body @[{:jolt/type :symbol :ns nil :name "fn"} @[{:jolt/type :symbol :ns nil :name (string "m")}] map-call])
# params must be a tuple (a vector), not an array — fn* treats an array
# first-arg as multi-arity clauses
(def map-body @[{:jolt/type :symbol :ns nil :name "fn"} [{:jolt/type :symbol :ns nil :name "m"}] map-call])
(def out @[{:jolt/type :symbol :ns nil :name "do"}
dt-form

50
src/jolt/evaluator.janet
View file

@ -466,6 +466,42 @@
(destructure-bind ctx bindings k v))))))
true (error (string "Unsupported destructuring pattern: " (string/format "%q" pat))))))
# ---- host-type protocol extension (extend-protocol String/Number/... ) ----
(def- host-type-names
{"Long" true "Integer" true "Short" true "Byte" true "BigInteger" true "BigInt" true
"Double" true "Float" true "Number" true "BigDecimal" true "Ratio" true
"String" true "CharSequence" true "Boolean" true "Character" true
"Keyword" true "Symbol" true "Object" true "IFn" true "Fn" true
"PersistentVector" true "PersistentList" true "PersistentHashMap" true
"PersistentHashSet" true "IPersistentMap" true "IPersistentVector" true
"IPersistentSet" true "IPersistentCollection" true "ISeq" true "Atom" true "nil" true})
(defn- canonical-host-tag
"If type-name names a host type (optionally java.*/clojure.lang.* qualified),
return its bare canonical name; else nil (it's a deftype/record name)."
[type-name]
(let [base (cond
(string/has-prefix? "java.lang." type-name) (string/slice type-name 10)
(string/has-prefix? "java.util." type-name) (string/slice type-name 10)
(string/has-prefix? "clojure.lang." type-name) (string/slice type-name 13)
type-name)]
(if (get host-type-names base) base nil)))
(defn- value-host-tags
"Candidate host type-tags for a runtime value, most-specific first."
[obj]
(cond
(number? obj) ["Long" "Integer" "Number" "Double" "Object"]
(string? obj) ["String" "CharSequence" "Object"]
(or (= true obj) (= false obj)) ["Boolean" "Object"]
(keyword? obj) ["Keyword" "Object"]
(and (struct? obj) (= :jolt/char (get obj :jolt/type))) ["Character" "Object"]
(and (struct? obj) (= :symbol (get obj :jolt/type))) ["Symbol" "Object"]
(or (tuple? obj) (array? obj)) ["PersistentVector" "IPersistentVector" "IPersistentCollection" "ISeq" "Object"]
(or (function? obj) (cfunction? obj)) ["IFn" "Fn" "Object"]
(nil? obj) ["nil" "Object"]
["Object"]))
# Dispatch a special form by its string name.
(defn- unwrap-meta-name
"Recursively unwrap (with-meta sym meta) forms to extract the underlying symbol.
@ -884,14 +920,24 @@
(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))))))
# host value: try candidate host type-tags (Long/String/Object/...)
(let [cands (value-host-tags obj)]
(var found nil)
(each tag cands
(when (nil? found)
(set found (find-protocol-method ctx tag proto-name method-name))))
(if found (apply found obj rest-args)
(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)
host (canonical-host-tag type-name)
# host types register under a bare canonical tag;
# deftype/record names stay namespace-qualified
type-tag (if host host (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))