core: move destructure from the Janet seed to the Clojure overlay
Port clojure.core/destructure into jolt-core/clojure/core/00-syntax.clj
and drop core-destructure (plus the d-* helpers) from core.janet. The
expander is now self-hosted, shrinking the seed per the jolt-1j0 epic.
It's def+fn* rather than defn because defn isn't defined yet at that
point in the syntax tier. Only the let macro consumes its output, so let
now splices [~@(destructure bindings)] to keep a tuple binding form.
Also fix a gap the old Janet version papered over via Janet's
keyword->string: :keys accepts keyword elements ({:keys [:major :minor]}),
so use name/namespace for the local + ns instead of str (which keeps the
colon). This was breaking sci's impl/namespaces.cljc. Added spec cases.
This commit is contained in:
Yogthos
parent
ad84b2904f
commit
77e3e3afcf
3 changed files with 92 additions and 84 deletions
|
|
@ -60,14 +60,99 @@
|
|||
;; pending cells (matching the prior Janet macro).
|
||||
(defmacro declare [& syms] `(do))
|
||||
|
||||
;; destructure — Clojure's binding-vector expander, ported from the Janet seed
|
||||
;; (was core-destructure). Turns a binding vector that may contain destructuring
|
||||
;; patterns into a plain binding vector (alternating symbol / init-form) built from
|
||||
;; nth/nthnext/get, so the COMPILER only ever sees plain symbols (analyze-bindings
|
||||
;; rejects patterns). `let` consumes it directly; `loop`/`fn` reuse it transitively
|
||||
;; through `let`. Written with let*/fn* and seed primitives only — it never uses
|
||||
;; let/loop/fn, so expanding its own body can't recurse back into destructure.
|
||||
;; Note map? is true for symbol structs too, so the symbol? clause must come first.
|
||||
;; def+fn* (not defn) because the defn macro is not defined until later in the tier.
|
||||
(def destructure
|
||||
(fn* destructure [bindings]
|
||||
(let* [find-or
|
||||
(fn* [or-map nm]
|
||||
(reduce (fn* [acc k]
|
||||
(if (and (symbol? k) (= nm (name k)))
|
||||
[true (get or-map k)]
|
||||
acc))
|
||||
[false nil]
|
||||
(if or-map (keys or-map) [])))
|
||||
amp? (fn* [x] (and (symbol? x) (= "&" (name x))))
|
||||
proc
|
||||
(fn* proc [pat init acc]
|
||||
(cond
|
||||
(symbol? pat) (conj (conj acc pat) init)
|
||||
(vector? pat)
|
||||
(let* [g (symbol (str (gensym)))
|
||||
n (count pat)
|
||||
vloop
|
||||
(fn* vloop [i idx a]
|
||||
(if (< i n)
|
||||
(let* [elem (nth pat i)]
|
||||
(cond
|
||||
(amp? elem)
|
||||
(vloop (+ i 2) idx (proc (nth pat (inc i)) `(nthnext ~g ~idx) a))
|
||||
(= elem :as)
|
||||
(vloop (+ i 2) idx (proc (nth pat (inc i)) g a))
|
||||
:else
|
||||
(vloop (inc i) (inc idx) (proc elem `(nth ~g ~idx nil) a))))
|
||||
a))]
|
||||
(vloop 0 0 (conj (conj acc g) init)))
|
||||
(map? pat)
|
||||
(let* [g (symbol (str (gensym)))
|
||||
or-map (get pat :or)
|
||||
as-sym (get pat :as)
|
||||
base (if as-sym
|
||||
(conj (conj (conj (conj acc g) init) as-sym) g)
|
||||
(conj (conj acc g) init))
|
||||
group
|
||||
(fn* [a kw kind]
|
||||
(let* [names (get pat kw)]
|
||||
(if names
|
||||
(reduce
|
||||
;; s is a symbol (a b) or a keyword (:a :b); name/
|
||||
;; namespace handle both, so :keys [:major] binds
|
||||
;; `major` looking up :major (str would keep the colon).
|
||||
(fn* [aa s]
|
||||
(let* [local (name s)
|
||||
nsp (namespace s)
|
||||
keyform (cond
|
||||
(= kind :kw) (keyword (if nsp (str nsp "/" local) local))
|
||||
(= kind :str) local
|
||||
:else `(quote ~(symbol nsp local)))
|
||||
fo (find-or or-map local)]
|
||||
(conj (conj aa (symbol local))
|
||||
(if (nth fo 0)
|
||||
`(get ~g ~keyform ~(nth fo 1))
|
||||
`(get ~g ~keyform)))))
|
||||
a names)
|
||||
a)))
|
||||
g1 (group base :keys :kw)
|
||||
g2 (group g1 :strs :str)
|
||||
g3 (group g2 :syms :sym)]
|
||||
(reduce (fn* [a k]
|
||||
(if (keyword? k)
|
||||
a
|
||||
(proc k `(get ~g ~(get pat k)) a)))
|
||||
g3 (keys pat)))
|
||||
:else (throw (str "unsupported destructuring pattern"))))
|
||||
ploop
|
||||
(fn* ploop [i acc]
|
||||
(if (< i (count bindings))
|
||||
(ploop (+ i 2) (proc (nth bindings i) (nth bindings (inc i)) acc))
|
||||
acc))]
|
||||
(ploop 0 []))))
|
||||
|
||||
;; let desugars destructuring patterns to plain bindings (via destructure) so the
|
||||
;; COMPILER sees only plain symbols — analyze-bindings rejects patterns as
|
||||
;; uncompilable, relying on this macro to have expanded them. (The interpreter
|
||||
;; could destructure let* directly, but the compiler can't.) let* is sequential, so
|
||||
;; a later init can reference an earlier destructured name. destructure is a
|
||||
;; clojure.core fn; calling it at expansion time is fine — it's interned at init.
|
||||
;; a later init can reference an earlier destructured name. Splice via [~@..] so the
|
||||
;; binding vector is a tuple form (destructure returns a pvec), not a pvec literal.
|
||||
(defmacro let [bindings & body]
|
||||
`(let* ~(destructure bindings) ~@body))
|
||||
`(let* [~@(destructure bindings)] ~@body))
|
||||
|
||||
;; loop binds destructuring forms like let, but recur must target the loop* vars,
|
||||
;; whose count can't change. So (matching Clojure): gensym one loop var per binding,
|
||||
|
|
|
|||
|
|
@ -2235,85 +2235,6 @@
|
|||
|
||||
# declare macro — accepts symbols, does nothing (forward declaration)
|
||||
|
||||
# --- Destructuring expansion (Clojure's `destructure`) -----------------------
|
||||
# Expands a binding vector containing destructuring patterns into a plain binding
|
||||
# vector (alternating plain-symbol / init-form), using nth/nthnext/get. Shared by
|
||||
# let/loop/fn so BOTH the interpreter and the compiler see only plain bindings —
|
||||
# the compiler can then compile destructuring (it never sees a pattern), and the
|
||||
# kernel needn't destructure at runtime. Mirrors evaluator/destructure-bind.
|
||||
|
||||
(defn- d-sym [name] {:jolt/type :symbol :ns nil :name name})
|
||||
(defn- d-amp? [x] (and (struct? x) (= :symbol (x :jolt/type)) (= "&" (x :name))))
|
||||
(defn- d-plain-sym? [x] (and (struct? x) (= :symbol (x :jolt/type))))
|
||||
|
||||
(defn- d-find-or [or-map nm]
|
||||
# [has-default default-form] for binding name nm in an :or map
|
||||
(var found false) (var dv nil)
|
||||
(when or-map
|
||||
(each k (keys or-map)
|
||||
(when (and (d-plain-sym? k) (= nm (k :name)))
|
||||
(set found true) (set dv (get or-map k)))))
|
||||
[found dv])
|
||||
|
||||
(var d-process nil)
|
||||
|
||||
(defn- d-vec [pat g out]
|
||||
(var i 0) (var idx 0) (def n (length pat))
|
||||
(while (< i n)
|
||||
(def elem (in pat i))
|
||||
(cond
|
||||
(d-amp? elem)
|
||||
(do (d-process (in pat (+ i 1)) @[(d-sym "nthnext") g idx] out) (+= i 2))
|
||||
(= elem :as)
|
||||
(do (d-process (in pat (+ i 1)) g out) (+= i 2))
|
||||
true
|
||||
(do (d-process elem @[(d-sym "nth") g idx nil] out) (++ idx) (++ i)))))
|
||||
|
||||
(defn- d-map [pat g out]
|
||||
(def or-map (get pat :or))
|
||||
(def as-sym (get pat :as))
|
||||
(when as-sym (array/push out as-sym) (array/push out g))
|
||||
(each spec [[:keys :kw] [:strs :str] [:syms :sym]]
|
||||
(def kw (in spec 0)) (def kind (in spec 1)) (def names (get pat kw))
|
||||
(when names
|
||||
(each s names
|
||||
(def is-sym (d-plain-sym? s))
|
||||
(def local (if is-sym (s :name) (string s)))
|
||||
# A namespaced symbol in :keys/:syms (x/y) looks up the namespaced key
|
||||
# but binds the bare local y.
|
||||
(def nsp (and is-sym (s :ns)))
|
||||
(def keyform (case kind
|
||||
:kw (keyword (if nsp (string nsp "/" local) local))
|
||||
:str local
|
||||
:sym @[(d-sym "quote") {:jolt/type :symbol :ns nsp :name local}]))
|
||||
(def fo (d-find-or or-map local))
|
||||
(array/push out (d-sym local))
|
||||
(array/push out (if (in fo 0)
|
||||
@[(d-sym "get") g keyform (in fo 1)]
|
||||
@[(d-sym "get") g keyform])))))
|
||||
(each k (keys pat)
|
||||
(when (not (keyword? k)) # explicit {pattern key-expr}
|
||||
(d-process k @[(d-sym "get") g (get pat k)] out))))
|
||||
|
||||
(set d-process
|
||||
(fn dp [pat init out]
|
||||
(cond
|
||||
(d-plain-sym? pat) (do (array/push out pat) (array/push out init))
|
||||
(tuple? pat) (let [g (gensym "_d__")]
|
||||
(array/push out g) (array/push out init) (d-vec pat g out))
|
||||
(and (struct? pat) (nil? (pat :jolt/type)))
|
||||
(let [g (gensym "_d__")]
|
||||
(array/push out g) (array/push out init) (d-map pat g out))
|
||||
(error "unsupported destructuring pattern"))))
|
||||
|
||||
(defn core-destructure
|
||||
"Clojure `destructure`: binding vector with patterns -> plain binding vector."
|
||||
[bindings]
|
||||
(def out @[])
|
||||
(var i 0) (def n (length bindings))
|
||||
(while (< i n) (d-process (in bindings i) (in bindings (+ i 1)) out) (+= i 2))
|
||||
(tuple/slice out))
|
||||
|
||||
# Build a protocol value (a self-evaluating tagged table). Exposed so the overlay
|
||||
# `defprotocol` can construct one via a fn call rather than embedding a tagged
|
||||
# struct literal (which the interpreter would try to re-evaluate). `methods` is a
|
||||
|
|
@ -3183,7 +3104,6 @@
|
|||
"remove-all-methods" core-remove-all-methods
|
||||
"prefer-method" core-prefer-method
|
||||
"Object" core-Object
|
||||
"destructure" core-destructure
|
||||
"make-protocol" core-make-protocol
|
||||
"satisfies?" core-satisfies?
|
||||
"extends?" core-extends?
|
||||
|
|
|
|||
|
|
@ -35,7 +35,10 @@
|
|||
[":strs" "7" "(let [{:strs [a]} {\"a\" 7}] a)"]
|
||||
[":syms" "8" "(let [{:syms [a]} {(quote a) 8}] a)"]
|
||||
["namespaced :keys" "3" "(let [{:keys [x/y]} {:x/y 3}] y)"]
|
||||
["namespaced :syms" "4" "(let [{:syms [p/q]} {(quote p/q) 4}] q)"])
|
||||
["namespaced :syms" "4" "(let [{:syms [p/q]} {(quote p/q) 4}] q)"]
|
||||
# :keys also accepts keyword elements ({:keys [:a :b]}), binding bare locals.
|
||||
["keyword :keys" "3" "(let [{:keys [:a :b]} {:a 1 :b 2}] (+ a b))"]
|
||||
["keyword :keys ns" "3" "(let [{:keys [:x/y]} {:x/y 3}] y)"])
|
||||
|
||||
(defspec "destructure / keyword args (& {:keys})"
|
||||
["fn kwargs" "[1 2]" "(do (defn f [& {:keys [a b]}] [a b]) (f :a 1 :b 2))"]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue