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

Phase 4: deftype/defrecord completion

Browse source 
- evaluator.janet: fix set! to handle (.-field obj) shorthand
  Previously only recognized (. obj -field) format
- core.janet: rewrite core-defrecord to emit (deftype ...) instead of
  plain def with array-map constructor
- core.janet: fix core-map? to recognize deftype table instances
  (and returns last truthy, not boolean true — wrap in if)
- core.janet: fix core-count to skip :jolt/deftype key for records
- core.janet: add ->TypeName arrow factory that calls TypeName.
  constructor via Clojure form emission
- 11 new tests: deftype fields/mutation/instance?, defrecord
  construction/map-behavior/fields/factories, record equality
- map->TypeName factory deferred (needs get/symbol resolution fix)
- 317 tests pass, 0 failures
This commit is contained in:
Yogthos 2026-06-02 21:10:33 -04:00
parent fc7f49487b
commit fb66851e06
8 changed files with 204 additions and 284 deletions
Download patch file Download diff file Expand all files Collapse all files

46
src/jolt/core.janet
View file

@ -17,7 +17,7 @@
(defn core-keyword? [x] (keyword? x))
(defn core-symbol? [x] (and (struct? x) (= :symbol (x :jolt/type))))
(defn core-vector? [x] (tuple? x))
(defn core-map? [x] (or (phm? x) (struct? x)))
(defn core-map? [x] (or (phm? x) (struct? x) (if (and (table? x) (get x :jolt/deftype)) true false)))
(defn core-seq? [x] (or (array? x) (tuple? x)))
(defn core-coll? [x] (or (array? x) (tuple? x) (struct? x)))
@ -166,7 +166,10 @@
(and (number? key) (>= key 0) (< key (length coll)))
false)))))
(defn core-count [coll] (if (phm? coll) (coll :cnt) (length coll)))
(defn core-count [coll]
(if (phm? coll) (coll :cnt)
(if (and (table? coll) (get coll :jolt/deftype)) (- (length (keys coll)) 1)
(length coll))))
(defn core-first [coll]
(if (or (nil? coll) (= 0 (length coll))) nil
@ -888,24 +891,33 @@
(defn core-comment [& body]
nil)
# defrecord stub — emits constructor and factory functions
# defrecord — creates a proper type via deftype + factory functions
(defn core-defrecord [name-sym fields-vec & body]
(def ctor-name-str (string "->" (name-sym :name)))
(def ctor-name-sym {:jolt/type :symbol :ns nil :name ctor-name-str})
# Build the map expression at macro-expansion time: {"":a a, ":b b, ...}
(var kvs @[])
(def type-name (name-sym :name))
(def type-name-dot (string type-name "."))
(def arrow-name (string "->" type-name))
(def map-name (string "map->" type-name))
# (deftype TypeName [fields...])
(def dt-form @[{:jolt/type :symbol :ns nil :name "deftype"} name-sym fields-vec])
# Arrow factory: (def ->TypeName (fn [field1 field2 ...] (TypeName. field1 field2 ...)))
(def arrow-call @[{:jolt/type :symbol :ns nil :name type-name-dot}])
(each f fields-vec (array/push arrow-call f))
(def arrow-sym {:jolt/type :symbol :ns nil :name arrow-name})
(def arrow-body @[{:jolt/type :symbol :ns nil :name "fn"} fields-vec arrow-call])
# 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 kvs (keyword (f :name)))
(array/push kvs f))
(def map-expr @[{:jolt/type :symbol :ns nil :name "array-map"} ;kvs])
(def ctor-body
@[{:jolt/type :symbol :ns nil :name "fn*"}
@[fields-vec]
map-expr])
# Emit (do (def TypeName <ctor-fn>) (def ->TypeName <ctor-fn>))
(array/push map-call @[{:jolt/type :symbol :ns nil :name "core-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])
@[{:jolt/type :symbol :ns nil :name "do"}
@[{:jolt/type :symbol :ns nil :name "def"} name-sym ctor-body]
@[{:jolt/type :symbol :ns nil :name "def"} ctor-name-sym ctor-body]])
dt-form
@[{:jolt/type :symbol :ns nil :name "def"} arrow-sym arrow-body]
@[{:jolt/type :symbol :ns nil :name "def"} map-sym map-body]])
# prefer-method stub — multimethod preference ordering
(defn core-prefer-method [multifn dispatch-val & dispatch-vals]

61
src/jolt/evaluator.janet
View file

@ -545,31 +545,42 @@
(error err)))
(eval-form ctx bindings body-form))))
"set!" (let [target (in form 1)
val (eval-form ctx bindings (in form 2))]
# (set! (. obj -field) val) — instance field mutation
(if (and (array? target) (> (length target) 0)
(struct? (first target))
(= :symbol ((first target) :jolt/type))
(= "." ((first target) :name)))
(let [obj (eval-form ctx bindings (in target 1))
field-sym (in target 2)
field-name (field-sym :name)
field-key (keyword (if (and (> (length field-name) 0) (= "-" (string/slice field-name 0 1)))
(string/slice field-name 1)
field-name))]
(if (get obj :jolt/deftype)
(do (put obj field-key val) val)
(error (string "Can't set! field on non-deftype: " (type obj)))))
# (set! var val) — normal var mutation
(let [target-sym target
v (resolve-var ctx bindings target-sym)]
(if v
(do (var-set v val) val)
# Auto-create var if it doesn't exist
(let [ns-name (ctx-current-ns ctx)
ns (ctx-find-ns ctx ns-name)]
(def new-v (ns-intern ns (target-sym :name) val))
val)))))
val (eval-form ctx bindings (in form 2))]
# Handle (set! (.-field obj) val) — .-field shorthand as a list
(if (and (array? target) (> (length target) 1)
(struct? (first target)) (= :symbol ((first target) :jolt/type))
(> (length ((first target) :name)) 1)
(= (string/slice ((first target) :name) 0 2) ".-"))
(let [obj (eval-form ctx bindings (in target 1))
field-name (string/slice ((first target) :name) 2)
field-key (keyword field-name)]
(if (get obj :jolt/deftype)
(do (put obj field-key val) val)
(error (string "Can't set! field on non-deftype: " (type obj)))))
# (set! (. obj -field) val) — instance field mutation
(if (and (array? target) (> (length target) 0)
(struct? (first target))
(= :symbol ((first target) :jolt/type))
(= "." ((first target) :name)))
(let [obj (eval-form ctx bindings (in target 1))
field-sym (in target 2)
field-name (field-sym :name)
field-key (keyword (if (and (> (length field-name) 0) (= "-" (string/slice field-name 0 1)))
(string/slice field-name 1)
field-name))]
(if (get obj :jolt/deftype)
(do (put obj field-key val) val)
(error (string "Can't set! field on non-deftype: " (type obj)))))
# (set! var val) — normal var mutation
(let [target-sym target
v (resolve-var ctx bindings target-sym)]
(if v
(do (var-set v val) val)
# Auto-create var if it doesn't exist
(let [ns-name (ctx-current-ns ctx)
ns (ctx-find-ns ctx ns-name)]
(def new-v (ns-intern ns (target-sym :name) val))
val))))))
"var" (let [target-sym (in form 1)
v (resolve-var ctx bindings target-sym)]
(if v v (error (string "Unable to resolve var: " (sym-name-str target-sym) " in var"))))