6abbea3835
The corpus certifier (test/conformance) flagged four cases where jolt's hand-written :expected matched a real defect rather than Clojure. Fixed in the jolt-core overlay, corrected the spec :expected, re-certified against JVM Clojure: - ex-message: returns nil for a non-throwable (dropped the lenient string branch); still returns the message for ex-info. (jolt-l8e8) - munge: preserves the argument's type — a symbol munges to a symbol, not a string. (jolt-hc35) - print: (print nil) emits "nil", not "" (top-level nil guard; str yields ""). (jolt-pqio) - bounded-count: uses the counted? fast path (full count), else counts up to n via seq — was (min n (count coll)), wrong for counted colls. Added an uncounted-coll spec case. (jolt-2507) Removed the 4 :bug entries from known-divergences.edn (now certified), regenerated corpus + profile, re-minted the Chez bootstrap seed (clojure.core changed). Gates: Janet 155/0, JVM certify clean, both Chez corpus gates 2534 (floors raised), bootstrap 6/6, fixpoint intact.
1127 lines
43 KiB
Clojure
1127 lines
43 KiB
Clojure
;; clojure.core — collection tier. Pure, eager fns expressed as compositions of
|
|
;; already-frozen core primitives (reduce/assoc/get/conj/filter/vec/count/>=).
|
|
;; No host internals, no laziness, no macros — so they compile cleanly and stay
|
|
;; redefinable. Loaded after the seq tier; self-hosted in compile mode.
|
|
;;
|
|
;; Same migration rule as the seq tier (see 10-seq.clj): not in core-renames, no
|
|
;; internal Janet callers, not used by the self-hosted compiler.
|
|
|
|
;; Tiny leaves first — fns below in this tier (and 25-sorted) use them.
|
|
(defn some? [x] (not (nil? x)))
|
|
|
|
(defn identity [x] x)
|
|
|
|
(defn constantly [x] (fn [& args] x))
|
|
|
|
;; neg? throws on non-numbers via <, as Clojure's Numbers.isNeg does.
|
|
(defn neg? [x] (< x 0))
|
|
|
|
;; even?/odd? stay in the seed: (filter even? ...) is idiomatic-hot and the
|
|
;; overlay versions cost an extra call layer per element (seq-pipe bench 4x).
|
|
|
|
;; Variadic bit ops — canonical Clojure arities folding the binary host op
|
|
;; (__bit-* seams). 2-arg call sites still compile to the native janet op via
|
|
;; the backend's native-ops table, so the binary fast path is unchanged.
|
|
(defn bit-and
|
|
([x y] (__bit-and x y))
|
|
([x y & more] (reduce __bit-and (__bit-and x y) more)))
|
|
|
|
(defn bit-or
|
|
([x y] (__bit-or x y))
|
|
([x y & more] (reduce __bit-or (__bit-or x y) more)))
|
|
|
|
(defn bit-xor
|
|
([x y] (__bit-xor x y))
|
|
([x y & more] (reduce __bit-xor (__bit-xor x y) more)))
|
|
|
|
(defn bit-and-not
|
|
([x y] (__bit-and-not x y))
|
|
([x y & more] (reduce __bit-and-not (__bit-and-not x y) more)))
|
|
|
|
;; The printing family, over two host seams: __write (push a string to *out*)
|
|
;; and __pr-str1 (render ONE value readably). The renderer itself stays host —
|
|
;; it's representation-coupled (pvec/phm/phs/sorted internals) and shared with
|
|
;; the hot str. print uses str semantics (unreadable), pr/pr-str readable;
|
|
;; println/prn append the newline. Defined this early because printf and the
|
|
;; print-str family below call them. (print-method as a real multimethod is a
|
|
;; separate project.)
|
|
(defn pr-str [& xs]
|
|
(loop [out "" s (seq xs) first? true]
|
|
(if s
|
|
(recur (str out (if first? "" " ") (__pr-str1 (first s))) (next s) false)
|
|
out)))
|
|
|
|
(defn pr [& xs] (__write (apply pr-str xs)) nil)
|
|
|
|
(defn prn [& xs] (apply pr xs) (__write "\n") nil)
|
|
|
|
;; print renders each arg non-readably (strings/chars unquoted) like str — except
|
|
;; nil, which prints as "nil" (str yields ""). Only the top-level arg needs the
|
|
;; guard; nil nested in a collection already renders as "nil" via the collection
|
|
;; printer.
|
|
(defn print [& xs]
|
|
(__write (loop [out "" s (seq xs) first? true]
|
|
(if s
|
|
(let [x (first s)
|
|
r (if (nil? x) "nil" (str x))]
|
|
(recur (str out (if first? "" " ") r) (next s) false))
|
|
out)))
|
|
nil)
|
|
|
|
(defn println [& xs] (apply print xs) (__write "\n") nil)
|
|
|
|
;; Transient accumulation (canonical JVM form): assoc! into a native-backed
|
|
;; scratch table per element, then persistent! bulk-builds the HAMT once —
|
|
;; instead of a fresh persistent assoc (full trie-path rebuild) per element.
|
|
;; A transient map canonicalizes collection keys (it is canon-keyed, like a
|
|
;; PHM), so counting/grouping by collection value still works across map reps.
|
|
(defn frequencies [coll]
|
|
(persistent!
|
|
(reduce (fn [counts x] (assoc! counts x (inc (get counts x 0)))) (transient {}) coll)))
|
|
|
|
;; Buckets are transient vectors, not persistent ones: the JVM form rebuilds the
|
|
;; bucket's persistent vector per element (conj (get ret k []) x), an O(log n)
|
|
;; trie path-rebuild + alloc per element — so a coarse grouping (few large
|
|
;; buckets) is bound on that conj, not the map build. Push onto a per-bucket
|
|
;; native array (O(1)) instead, then bulk-build the persistent map ONCE.
|
|
;; Distinct keys are recorded in a side vector so the buckets can be frozen in
|
|
;; place (no second map rebuild). A bucket's FIRST element is stored as a cheap
|
|
;; persistent [x]; only the second element promotes it to a transient — so an
|
|
;; all-singletons grouping pays no transient alloc and matches the old cost,
|
|
;; while any bucket that actually grows rides the O(1) push.
|
|
(defn group-by [f coll]
|
|
(let [tm (transient {})
|
|
ks (reduce (fn [ks x]
|
|
(let [k (f x)
|
|
b (get tm k)]
|
|
(if (nil? b)
|
|
(do (assoc! tm k [x]) (conj! ks k))
|
|
(if (vector? b)
|
|
(do (assoc! tm k (conj! (transient b) x)) ks)
|
|
(do (conj! b x) ks)))))
|
|
(transient []) coll)]
|
|
(reduce (fn [_ k]
|
|
(let [b (get tm k)]
|
|
(if (vector? b) nil (assoc! tm k (persistent! b)))))
|
|
nil (persistent! ks))
|
|
(persistent! tm)))
|
|
|
|
(defn not-empty [coll]
|
|
(if (or (nil? coll) (zero? (count coll))) nil coll))
|
|
|
|
(defn filterv [pred coll]
|
|
(vec (filter pred coll)))
|
|
|
|
;; Greatest/least x by (k x). Canonical Clojure multi-arity: the first pair uses
|
|
;; strict < / > and the fold uses <= / >= — this exact ordering reproduces the
|
|
;; JVM IEEE-754 NaN behavior (e.g. (min-key identity 1 ##NaN) => ##NaN). > / <
|
|
;; throw on non-numbers, as Clojure does.
|
|
(defn max-key
|
|
([k x] x)
|
|
([k x y] (if (> (k x) (k y)) x y))
|
|
([k x y & more]
|
|
(let [kx (k x) ky (k y)
|
|
v (if (> kx ky) x y)
|
|
kv (if (> kx ky) kx ky)]
|
|
(loop [v v kv kv more more]
|
|
(if (seq more)
|
|
(let [w (first more) kw (k w)]
|
|
(if (>= kw kv) (recur w kw (next more)) (recur v kv (next more))))
|
|
v)))))
|
|
|
|
(defn min-key
|
|
([k x] x)
|
|
([k x y] (if (< (k x) (k y)) x y))
|
|
([k x y & more]
|
|
(let [kx (k x) ky (k y)
|
|
v (if (< kx ky) x y)
|
|
kv (if (< kx ky) kx ky)]
|
|
(loop [v v kv kv more more]
|
|
(if (seq more)
|
|
(let [w (first more) kw (k w)]
|
|
(if (<= kw kv) (recur w kw (next more)) (recur v kv (next more))))
|
|
v)))))
|
|
|
|
;; Function combinators (pure HOFs).
|
|
(defn juxt [& fs]
|
|
(fn [& args] (mapv (fn [f] (apply f args)) fs)))
|
|
|
|
(defn every-pred [& preds]
|
|
(fn [& xs] (every? (fn [p] (every? p xs)) preds)))
|
|
|
|
(defn some [pred coll]
|
|
(when-let [s (seq coll)]
|
|
(or (pred (first s)) (recur pred (next s)))))
|
|
|
|
(defn some-fn [& preds]
|
|
(fn [& xs] (some (fn [p] (some p xs)) preds)))
|
|
|
|
(defn not-any? [pred coll] (not (some pred coll)))
|
|
|
|
(defn not-every? [pred coll] (not (every? pred coll)))
|
|
|
|
(defn split-at [n coll] [(take n coll) (drop n coll)])
|
|
|
|
(defn split-with [pred coll] [(take-while pred coll) (drop-while pred coll)])
|
|
|
|
(defn qualified-keyword? [x] (and (keyword? x) (some? (namespace x))))
|
|
(defn simple-keyword? [x] (and (keyword? x) (nil? (namespace x))))
|
|
(defn qualified-symbol? [x] (and (symbol? x) (some? (namespace x))))
|
|
(defn simple-symbol? [x] (and (symbol? x) (nil? (namespace x))))
|
|
|
|
(defn ident? [x] (or (keyword? x) (symbol? x)))
|
|
|
|
(defn qualified-ident? [x] (or (qualified-symbol? x) (qualified-keyword? x)))
|
|
|
|
(defn simple-ident? [x] (or (simple-symbol? x) (simple-keyword? x)))
|
|
|
|
;; Jolt has no ratio or bigdecimal types, so these are constants / reduce to int?.
|
|
(defn ratio? [x] false)
|
|
(defn decimal? [x] false)
|
|
;; No first-class Class objects either: class names are symbols the evaluator
|
|
;; handles in instance?/new positions, never values — so nothing is a class.
|
|
(defn class? [x] false)
|
|
(defn rational? [x] (int? x))
|
|
(defn nat-int? [x] (and (int? x) (>= x 0)))
|
|
(defn neg-int? [x] (and (int? x) (neg? x)))
|
|
(defn pos-int? [x] (and (int? x) (pos? x)))
|
|
|
|
(defn replicate [n x] (map (fn [_] x) (range n)))
|
|
|
|
(defn take-last [n coll]
|
|
(let [c (vec coll) len (count c)]
|
|
(when (pos? len) (subvec c (max 0 (- len n))))))
|
|
|
|
(defn drop-last
|
|
([coll] (drop-last 1 coll))
|
|
([n coll] (let [c (vec coll)] (subvec c 0 (max 0 (- (count c) n))))))
|
|
|
|
(defn distinct?
|
|
([x] true)
|
|
([x y] (not (= x y)))
|
|
([x y & more]
|
|
(if (not (= x y))
|
|
(loop [s #{x y} xs more]
|
|
(if xs
|
|
(let [x (first xs)]
|
|
(if (contains? s x) false (recur (conj s x) (next xs))))
|
|
true))
|
|
false)))
|
|
|
|
(defn replace [smap coll] (mapv (fn [x] (get smap x x)) coll))
|
|
|
|
(defn nthnext [coll n]
|
|
(loop [n n xs (seq coll)]
|
|
(if (and xs (pos? n))
|
|
(recur (dec n) (next xs))
|
|
xs)))
|
|
|
|
(defn bounded-count [n coll]
|
|
(if (counted? coll)
|
|
(count coll)
|
|
(loop [i 0 s (seq coll)]
|
|
(if (and s (< i n)) (recur (inc i) (next s)) i))))
|
|
|
|
(defn run! [proc coll] (reduce (fn [_ x] (proc x) nil) nil coll) nil)
|
|
|
|
(defn completing
|
|
([f] (completing f identity))
|
|
([f cf] (fn ([] (f)) ([x] (cf x)) ([x y] (f x y)))))
|
|
|
|
;; Matches Clojure exactly: n<=0 returns coll unchanged; for n>0 the walk yields
|
|
;; (seq xs), and an exhausted/nil walk falls back to () via (or ... ()) — so
|
|
;; (nthrest nil 100) is () (not nil), while (nthrest nil 0) is nil.
|
|
(defn nthrest [coll n]
|
|
(if (pos? n)
|
|
(or (loop [n n xs coll]
|
|
(let [s (and (pos? n) (seq xs))]
|
|
(if s (recur (dec n) (rest s)) (seq xs))))
|
|
(list))
|
|
coll))
|
|
|
|
(defn abs [x] (if (neg? x) (- 0 x) x))
|
|
|
|
(defn NaN? [x]
|
|
(if (number? x) (not (= x x)) (throw (str "NaN? requires a number"))))
|
|
|
|
;; No distinct host object / undefined types on Jolt.
|
|
(defn object? [x] false)
|
|
(defn undefined? [x] false)
|
|
|
|
(defn keyword-identical? [a b] (= a b))
|
|
|
|
;; Clojure 1.9: true for ANY argument incl. nil (used as a spec predicate).
|
|
(defn any? [x] true)
|
|
|
|
;; printf: print (no newline) the formatted string to *out*.
|
|
(defn printf [fmt & args] (print (apply format fmt args)))
|
|
|
|
;; bound?: every var has a root value. (jolt vars store the root in :root;
|
|
;; a nil-valued root reads as unbound — documented divergence.)
|
|
(defn bound? [& vars]
|
|
(every? (fn [v] (some? (get v :root))) vars))
|
|
|
|
;; Run f with a frame of dynamic bindings installed; restore on exit.
|
|
(defn with-bindings* [binding-map f & args]
|
|
(push-thread-bindings binding-map)
|
|
(try
|
|
(apply f args)
|
|
(finally (pop-thread-bindings))))
|
|
|
|
;; Capture the CURRENT thread bindings; the returned fn re-installs them
|
|
;; around every call (binding conveyance — Clojure's bound-fn*).
|
|
(defn bound-fn* [f]
|
|
(let [bs (get-thread-bindings)]
|
|
(fn [& args] (apply with-bindings* bs f args))))
|
|
|
|
(defn thread-bound? [& vars]
|
|
(every? (fn [v] (__thread-bound? v)) vars))
|
|
|
|
(defn key [e] (if (map-entry? e) (nth e 0) (throw (ex-info "key requires a map entry" {}))))
|
|
(defn val [e] (if (map-entry? e) (nth e 1) (throw (ex-info "val requires a map entry" {}))))
|
|
|
|
;; --- Ad-hoc hierarchies (stage 3) — Clojure's canonical pure-map port. -----
|
|
;; A hierarchy is {:parents {tag #{parents}} :ancestors {tag #{all}}
|
|
;; :descendants {tag #{all}}}. The 3-arity forms are PURE; the 1/2-arity forms
|
|
;; operate on the private global hierarchy atom. Multimethod dispatch
|
|
;; (evaluator defmulti-setup) calls isa? through the interned var.
|
|
|
|
(defn make-hierarchy []
|
|
{:parents {} :descendants {} :ancestors {}})
|
|
|
|
(def ^:private global-hierarchy (atom (make-hierarchy)))
|
|
|
|
(defn isa?
|
|
([child parent] (isa? (deref global-hierarchy) child parent))
|
|
([h child parent]
|
|
(or (= child parent)
|
|
(contains? (get (get h :ancestors) child #{}) parent)
|
|
(and (vector? parent) (vector? child)
|
|
(= (count parent) (count child))
|
|
(loop [ret true i 0]
|
|
(if (or (not ret) (= i (count parent)))
|
|
ret
|
|
(recur (isa? h (nth child i) (nth parent i)) (inc i))))))))
|
|
|
|
(defn parents
|
|
([tag] (parents (deref global-hierarchy) tag))
|
|
([h tag] (not-empty (get (get h :parents) tag))))
|
|
|
|
(defn ancestors
|
|
([tag] (ancestors (deref global-hierarchy) tag))
|
|
([h tag] (not-empty (get (get h :ancestors) tag))))
|
|
|
|
(defn descendants
|
|
([tag] (descendants (deref global-hierarchy) tag))
|
|
([h tag] (not-empty (get (get h :descendants) tag))))
|
|
|
|
(defn derive
|
|
([tag parent] (swap! global-hierarchy derive tag parent) nil)
|
|
([h tag parent]
|
|
(let [tp (get h :parents)
|
|
td (get h :descendants)
|
|
ta (get h :ancestors)
|
|
tf (fn [m source sources target targets]
|
|
(reduce (fn [ret k]
|
|
(assoc ret k
|
|
(reduce conj (get targets k #{})
|
|
(cons target (get targets target)))))
|
|
m (cons source (get sources source))))]
|
|
(or
|
|
(when-not (contains? (get tp tag #{}) parent)
|
|
(when (contains? (get ta tag #{}) parent)
|
|
(throw (str tag " already has " parent " as ancestor")))
|
|
(when (contains? (get ta parent #{}) tag)
|
|
(throw (str "Cyclic derivation: " parent " has " tag " as ancestor")))
|
|
{:parents (assoc tp tag (conj (get tp tag #{}) parent))
|
|
:ancestors (tf ta tag td parent ta)
|
|
:descendants (tf td parent ta tag td)})
|
|
h))))
|
|
|
|
(defn underive
|
|
([tag parent] (swap! global-hierarchy underive tag parent) nil)
|
|
([h tag parent]
|
|
(let [parent-map (get h :parents)
|
|
childs-parents (if (get parent-map tag)
|
|
(disj (get parent-map tag) parent)
|
|
#{})
|
|
new-parents (if (not-empty childs-parents)
|
|
(assoc parent-map tag childs-parents)
|
|
(dissoc parent-map tag))
|
|
deriv-seq (mapcat (fn [e] (cons (key e) (interpose (key e) (val e))))
|
|
(seq new-parents))]
|
|
(if (contains? (get parent-map tag #{}) parent)
|
|
(reduce (fn [p [t pr]] (derive p t pr))
|
|
(make-hierarchy) (partition 2 deriv-seq))
|
|
h))))
|
|
|
|
;; --- Stage 3 tier shrink: pure-over-core leaves moved off the Janet seed ----
|
|
|
|
;; Representation predicates over the overlay's own predicates (no Janet reps).
|
|
(defn sequential? [x] (or (vector? x) (seq? x)))
|
|
(defn associative? [x] (or (map? x) (vector? x)))
|
|
(defn counted? [x]
|
|
(or (vector? x) (map? x) (set? x) (list? x) (string? x)))
|
|
(defn indexed? [x] (vector? x))
|
|
;; sorted? is defined by the next tier (25-sorted) — declared here so this
|
|
;; tier compiles (forward references are analysis errors now, jolt-2o7.3).
|
|
(declare sorted?)
|
|
|
|
(defn reversible? [x] (or (vector? x) (sorted? x)))
|
|
(defn seqable? [x]
|
|
(or (nil? x) (coll? x) (string? x)))
|
|
|
|
(defn boolean? [x] (or (true? x) (false? x)))
|
|
(defn double? [x] (and (number? x) (not (integer? x))))
|
|
(defn float? [x] (double? x))
|
|
(defn infinite? [x] (and (number? x) (or (= x ##Inf) (= x ##-Inf))))
|
|
|
|
;; qualified-/simple- keyword?/symbol? moved above qualified-ident? (forward
|
|
;; references are analysis errors now — jolt-2o7.3).
|
|
|
|
|
|
;; realized?: defined on the pending types only (delay/lazy-seq/future read
|
|
;; Tagged-value predicates. The constructors (atom/volatile!/...) stay in Janet,
|
|
;; but every tagged value carries its kind under :jolt/type (records under
|
|
;; :jolt/deftype), reachable via get — which is nil on non-tables — so the
|
|
;; predicates are pure over get and move out of the seed.
|
|
(defn atom? [x] (= (get x :jolt/type) :jolt/atom))
|
|
(defn volatile? [x] (= (get x :jolt/type) :jolt/volatile))
|
|
(defn reader-conditional? [x] (= (get x :jolt/type) :jolt/reader-conditional))
|
|
(defn tagged-literal? [x] (= (get x :jolt/type) :jolt/tagged-literal))
|
|
(defn record? [x] (some? (get x :jolt/deftype)))
|
|
(defn uuid? [x] (= (get x :jolt/type) :jolt/uuid))
|
|
(defn inst? [x] (= (get x :jolt/type) :jolt/inst))
|
|
(defn char? [x] (= (get x :jolt/type) :jolt/char))
|
|
|
|
;; their realization slot; promises/atoms always-realized), error otherwise.
|
|
(defn realized? [x]
|
|
(cond
|
|
(delay? x) (boolean (get x :realized))
|
|
(future? x) (boolean (get x :cached))
|
|
(= :jolt/lazy-seq (get x :jolt/type)) (boolean (get x :realized))
|
|
(atom? x) true
|
|
:else (throw (str "realized? not supported on: " x))))
|
|
|
|
(defn force [x] (if (delay? x) (deref x) x))
|
|
|
|
;; pop: vectors drop the last element, lists/seqs the first; empty pops throw.
|
|
(defn pop [coll]
|
|
(cond
|
|
(nil? coll) nil
|
|
(vector? coll)
|
|
(if (zero? (count coll)) (throw "Can't pop empty vector")
|
|
(subvec coll 0 (dec (count coll))))
|
|
(seq? coll)
|
|
(if (nil? (seq coll)) (throw "Can't pop empty list")
|
|
(rest coll))
|
|
:else (throw (str "pop not supported on: " coll))))
|
|
|
|
;; doall/dorun: realization boundaries. dorun walks (optionally at most n
|
|
;; steps — the Janet seed version ignored n); doall walks then returns coll.
|
|
(defn dorun
|
|
([coll]
|
|
(loop [s (seq coll)]
|
|
(when s (recur (next s)))))
|
|
([n coll]
|
|
(loop [n n s (seq coll)]
|
|
(when (and s (pos? n)) (recur (dec n) (next s))))))
|
|
|
|
(defn doall
|
|
([coll] (dorun coll) coll)
|
|
([n coll] (dorun n coll) coll))
|
|
|
|
;; spread: (spread [1 2 [3 4]]) => (1 2 3 4) — list*'s variadic helper
|
|
;; (private in Clojure).
|
|
(defn- spread [arglist]
|
|
(cond
|
|
(nil? arglist) nil
|
|
(nil? (next arglist)) (seq (first arglist))
|
|
:else (cons (first arglist) (spread (next arglist)))))
|
|
|
|
;; list*: cons the leading args onto the final seq argument.
|
|
(defn list*
|
|
([args] (seq args))
|
|
([a args] (cons a args))
|
|
([a b args] (cons a (cons b args)))
|
|
([a b c args] (cons a (cons b (cons c args))))
|
|
([a b c d & more]
|
|
(cons a (cons b (cons c (cons d (spread more)))))))
|
|
|
|
;; print-str family: print/println/prn into a captured *out*.
|
|
(defn print-str [& xs] (__with-out-str (fn* [] (apply print xs))))
|
|
(defn println-str [& xs] (__with-out-str (fn* [] (apply println xs))))
|
|
(defn prn-str [& xs] (__with-out-str (fn* [] (apply prn xs))))
|
|
|
|
;; --- Phase 2 leaf batch 4 (jolt-ded): over the rand / sort host seams --------
|
|
|
|
;; Canonical truncation toward zero via int (the kernel fn floored, which is
|
|
;; wrong for a negative n).
|
|
(defn rand-int [n] (int (rand n)))
|
|
|
|
;; Pure-functional Fisher-Yates over vector assoc; returns a vector, as in
|
|
;; Clojure. Collections only — a string is seqable but not shuffleable, as on
|
|
;; the JVM (Collections/shuffle wants a Collection).
|
|
(defn shuffle [coll]
|
|
(when-not (coll? coll)
|
|
(throw (ex-info (str "shuffle requires a collection, got: " coll) {})))
|
|
(loop [v (vec coll) i (dec (count v))]
|
|
(if (pos? i)
|
|
(let [j (rand-int (inc i))
|
|
t (nth v i)]
|
|
(recur (assoc (assoc v i (nth v j)) j t) (dec i)))
|
|
v)))
|
|
|
|
;; Canonical sort-by: the default comparator is compare (so nil sorts first,
|
|
;; like Clojure — the kernel fn used host ordering, which put nil last); the
|
|
;; comparator compares KEYS and may be 3-way or a boolean predicate (the host
|
|
;; sort seam normalizes).
|
|
(defn sort-by
|
|
([keyfn coll] (sort-by keyfn compare coll))
|
|
([keyfn comp coll]
|
|
(sort (fn [x y] (comp (keyfn x) (keyfn y))) coll)))
|
|
|
|
;; parse-uuid: nil unless s is a canonical 8-4-4-4-12 hex UUID string; throws
|
|
;; on a non-string (Clojure 1.11). __make-uuid is the host constructor for the
|
|
;; tagged value (overlay source can't write :jolt/type map literals — the
|
|
;; reader treats them as tagged forms).
|
|
(defn parse-uuid [s]
|
|
(if (string? s)
|
|
(when (re-matches
|
|
#"[0-9a-fA-F]{8}-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-[0-9a-fA-F]{12}" s)
|
|
(__make-uuid s))
|
|
(throw (str "parse-uuid requires a string, got: " s))))
|
|
|
|
;; Version-4 UUID (RFC 4122): zero-padded hex groups 8-4-4-4-12, version
|
|
;; nibble 4, variant 8-b — built over rand-int and validated by parse-uuid.
|
|
(defn random-uuid []
|
|
(let [hx4 (fn [] (format "%04x" (rand-int 0x10000)))
|
|
hx3 (fn [] (format "%03x" (rand-int 0x1000)))]
|
|
(parse-uuid (str (hx4) (hx4) "-" (hx4) "-4" (hx3)
|
|
"-" (format "%x" (+ 8 (rand-int 4))) (hx3)
|
|
"-" (hx4) (hx4) (hx4)))))
|
|
|
|
;; The char escape/name tables, as char-keyed maps (Clojure's shape).
|
|
(def ^:private char-escape-strings
|
|
{\newline "\\n" \tab "\\t" \return "\\r" \formfeed "\\f"
|
|
\backspace "\\b" \" "\\\"" \\ "\\\\"})
|
|
(defn char-escape-string [c] (get char-escape-strings c))
|
|
|
|
(def ^:private char-name-strings
|
|
{\newline "newline" \tab "tab" \return "return" \formfeed "formfeed"
|
|
\backspace "backspace" \space "space"})
|
|
(defn char-name-string [c] (get char-name-strings c))
|
|
|
|
;; Random selection over the host rand primitives.
|
|
(defn rand-nth [coll]
|
|
(let [v (vec coll)] (nth v (rand-int (count v)))))
|
|
|
|
(defn random-sample
|
|
([prob] (filter (fn [_] (< (rand) prob))))
|
|
([prob coll] (filter (fn [_] (< (rand) prob)) coll)))
|
|
|
|
(defn comparator [pred]
|
|
(fn [a b] (cond (pred a b) -1 (pred b a) 1 :else 0)))
|
|
|
|
;; Lazy: the running accumulators, one at a time (matches Clojure).
|
|
(defn reductions
|
|
([f coll]
|
|
(lazy-seq
|
|
(let [s (seq coll)]
|
|
(if s
|
|
(reductions f (first s) (rest s))
|
|
(list (f))))))
|
|
([f init coll]
|
|
(cons init
|
|
(lazy-seq
|
|
(when-let [s (seq coll)]
|
|
(reductions f (f init (first s)) (rest s)))))))
|
|
|
|
;; Lazy pre-order DFS (matches Clojure): node, then its children's walks spliced
|
|
;; via the (now lazy) mapcat.
|
|
(defn tree-seq [branch? children root]
|
|
(let [walk (fn walk [node]
|
|
(lazy-seq
|
|
(cons node
|
|
(when (branch? node)
|
|
(mapcat walk (children node))))))]
|
|
(walk root)))
|
|
|
|
;; file-seq: the tree of paths under root (root included), directories walked
|
|
;; via the host dir primitives. Paths (strings), not File objects. (Lives below
|
|
;; tree-seq: forward references are analysis errors now — jolt-2o7.3.)
|
|
(defn file-seq [root]
|
|
(if (__file? root)
|
|
;; java.io.File tree: walk via the File method surface so leaves are File
|
|
;; values callers can invoke .isFile/.getName/slurp on (jolt-hjw).
|
|
(tree-seq (fn [f] (.isDirectory f)) (fn [f] (seq (.listFiles f))) root)
|
|
(tree-seq __dir? __list-dir root)))
|
|
|
|
;; Canonical flatten via tree-seq: the leaves (non-sequential nodes) in order.
|
|
;; Flattens lists too (sequential?), matching Clojure/CLJS.
|
|
(defn flatten [coll]
|
|
(filter (complement sequential?) (rest (tree-seq sequential? seq coll))))
|
|
|
|
;; xml-seq: tree-seq over XML element trees. Elements are maps with :content.
|
|
(defn xml-seq [root]
|
|
(tree-seq (complement string?) (comp seq :content) root))
|
|
|
|
;; Lazy interleave: round-robin one element from each coll until any exhausts.
|
|
(defn interleave
|
|
([] ())
|
|
([c1] (lazy-seq c1))
|
|
([c1 c2]
|
|
(lazy-seq
|
|
(let [s1 (seq c1) s2 (seq c2)]
|
|
(when (and s1 s2)
|
|
(cons (first s1)
|
|
(cons (first s2)
|
|
(interleave (rest s1) (rest s2))))))))
|
|
([c1 c2 & cs]
|
|
(lazy-seq
|
|
(let [ss (map seq (list* c1 c2 cs))]
|
|
(when (every? identity ss)
|
|
(concat (map first ss)
|
|
(apply interleave (map rest ss))))))))
|
|
|
|
;; No ratio type on Jolt, so rationalize is identity.
|
|
(defn rationalize [x] x)
|
|
|
|
;; trampoline: repeatedly calls f with args until a non-function result.
|
|
|
|
;; rand-int: random integer in [0, n). Uses Janet math/random.
|
|
|
|
;; Eager dedupe of consecutive equal elements (Jolt has no transducer arity yet).
|
|
(defn dedupe [coll]
|
|
(let [step (fn step [s prev]
|
|
(make-lazy-seq
|
|
(fn* []
|
|
(let [s (seq s)]
|
|
(if s
|
|
(let [x (first s)]
|
|
(if (= x prev)
|
|
(coll->cells (step (rest s) prev))
|
|
(coll->cells (cons x (step (rest s) x)))))
|
|
nil)))))]
|
|
(let [s (seq coll)]
|
|
(if s
|
|
(make-lazy-seq
|
|
(fn* [] (coll->cells (cons (first s) (step (rest s) (first s))))))
|
|
()))))
|
|
|
|
;; Internal helper for {:keys [...]} destructuring over a seq of k/v pairs —
|
|
;; canonical Clojure 1.11 shape (core.clj seq-to-map-for-destructuring):
|
|
;; even pairs build a map (later keys win, as createAsIfByAssoc), a SINGLE
|
|
;; element is returned as-is (the trailing-map calling convention), and an
|
|
;; unpaired key past pairs throws. The old jolt version silently dropped the
|
|
;; trailing element, losing (f {:b 2}) kwargs calls.
|
|
(defn seq-to-map-for-destructuring [s]
|
|
(if (next s)
|
|
(loop [m {} xs (seq s)]
|
|
(if xs
|
|
(if (next xs)
|
|
(recur (assoc m (first xs) (second xs)) (nnext xs))
|
|
(throw (str "No value supplied for key: " (first xs))))
|
|
m))
|
|
(if (seq s) (first s) {})))
|
|
|
|
;; Phase 4 (jolt-1j0): host-coupled fns that are pure logic over existing core
|
|
;; primitives, so they need no new jolt.host surface.
|
|
|
|
;; vary-meta: f applied to obj's metadata (+ extra args), reattached. meta and
|
|
;; with-meta are the irreducible host primitives; vary-meta is just their compose.
|
|
(defn vary-meta [obj f & args]
|
|
(with-meta obj (apply f (meta obj) args)))
|
|
|
|
;; namespace-munge: Clojure namespace name -> legal Java package name (- -> _).
|
|
(defn namespace-munge [s]
|
|
(apply str (map (fn [c] (if (= c \-) \_ c)) (seq (str s)))))
|
|
|
|
;; reduce-kv over a map (k v) or vector (index v). Both branches go through reduce,
|
|
;; so reduced short-circuits — and the vector path indexes correctly. (The prior
|
|
;; Janet version saw a pvec as a table and folded over its internal keys; it also
|
|
;; ignored reduced.) nil folds to init, matching Clojure.
|
|
(defn reduce-kv [f init coll]
|
|
(cond
|
|
(vector? coll) (reduce (fn [acc i] (f acc i (nth coll i))) init (range (count coll)))
|
|
(map? coll) (reduce (fn [acc k] (f acc k (get coll k))) init (keys coll))
|
|
(nil? coll) init
|
|
:else (throw (str "reduce-kv not supported on: " coll))))
|
|
|
|
;; ex-info accessors. The Janet constructor (ex-info) stays — it builds the tagged
|
|
;; value and wires into throw — but the value exposes :jolt/type/:message/:data/
|
|
;; :cause via get, so the accessors are pure over get. A thrown non-ex-info arrives
|
|
;; wrapped as {:jolt/type :jolt/exception :value v}; unwrap that first.
|
|
(defn- ex-info-val? [x] (= (get x :jolt/type) :jolt/ex-info))
|
|
(defn- ex-unwrap [e]
|
|
(if (= (get e :jolt/type) :jolt/exception) (get e :value) e))
|
|
(defn ex-data [e]
|
|
(let [e (ex-unwrap e)] (if (ex-info-val? e) (get e :data) nil)))
|
|
(defn ex-message [e]
|
|
(let [e (ex-unwrap e)]
|
|
(cond (ex-info-val? e) (get e :message)
|
|
:else nil)))
|
|
(defn ex-cause [e]
|
|
(let [e (ex-unwrap e)] (if (ex-info-val? e) (get e :cause) nil)))
|
|
|
|
;; inst-ms: epoch milliseconds of an instant; throws on a non-inst (Clojure
|
|
;; protocol behavior).
|
|
(defn inst-ms [x]
|
|
(if (inst? x) (get x :ms) (throw (str "inst-ms requires an inst, got: " x))))
|
|
|
|
;; Clojure 1.11 map transformers. PHM base so transformed keys canonicalize
|
|
;; (collisions: last entry in seq order wins, matching the reference).
|
|
(defn update-keys [m f]
|
|
(reduce-kv (fn [acc k v] (assoc acc (f k) v)) (hash-map) m))
|
|
|
|
(defn update-vals [m f]
|
|
(reduce-kv (fn [acc k v] (assoc acc k (f v))) (hash-map) m))
|
|
|
|
;; Vector-returning partition variants (1.11): lazy seqs OF vectors.
|
|
(defn partitionv
|
|
([n coll] (map vec (partition n coll)))
|
|
([n step coll] (map vec (partition n step coll)))
|
|
([n step pad coll] (map vec (partition n step pad coll))))
|
|
|
|
;; partition-all is a lazy-tier fn (40-lazy) — declared so partitionv-all
|
|
;; compiles; bound by the time anything calls it.
|
|
(declare partition-all)
|
|
|
|
(defn partitionv-all
|
|
([n coll] (map vec (partition-all n coll)))
|
|
([n step coll] (map vec (partition-all n step coll))))
|
|
|
|
;; First part a vector, rest a seq — matching the reference implementation.
|
|
(defn splitv-at [n coll]
|
|
[(vec (take n coll)) (drop n coll)])
|
|
|
|
;; with-redefs-fn: temporarily set each var's root to the mapped value, run
|
|
;; the thunk, restore the saved roots even on throw. The with-redefs macro
|
|
;; (30-macros) builds the {var val} map from names.
|
|
(defn with-redefs-fn [binding-map func]
|
|
(let [vars (vec (keys binding-map))
|
|
saved (mapv var-get vars)]
|
|
(doseq [v vars] (var-set v (get binding-map v)))
|
|
(try
|
|
(func)
|
|
(finally
|
|
;; loop/recur, not dotimes: dotimes is a 30-macros macro and this tier
|
|
;; compiles before it exists (a forward ref would resolve to the macro
|
|
;; fn at runtime and mis-apply it).
|
|
(loop [i 0]
|
|
(when (< i (count vars))
|
|
(var-set (nth vars i) (nth saved i))
|
|
(recur (inc i))))))))
|
|
;; Jolt has no chunked seqs (Phase 5 territory), so this is always false.
|
|
(defn chunked-seq? [x] false)
|
|
|
|
;; Atom peripheral operations. atom/swap!/reset!/deref stay native — the compiler
|
|
;; depends on them and they're hot. swap-vals!/reset-vals!/compare-and-set! compose
|
|
;; the native ops (which already validate and notify watches); get-validator reads a
|
|
;; slot; add-watch/remove-watch/set-validator! mutate the atom (or its watches
|
|
;; sub-table) through the one host primitive jolt.host/ref-put! — the minimal
|
|
;; mutation kernel the overlay can't express over core fns (a nil value removes the
|
|
;; key). compare-and-set! compares by value, matching the prior Janet behavior.
|
|
(defn swap-vals! [a f & args]
|
|
(let [old (deref a)] [old (apply swap! a f args)]))
|
|
(defn reset-vals! [a newval]
|
|
(let [old (deref a)] (reset! a newval) [old newval]))
|
|
(defn compare-and-set! [a oldval newval]
|
|
(if (= oldval (deref a)) (do (reset! a newval) true) false))
|
|
(defn get-validator [a] (get a :validator))
|
|
(defn add-watch [a key f]
|
|
(jolt.host/ref-put! (get a :watches) key f) a)
|
|
(defn remove-watch [a key]
|
|
(jolt.host/ref-put! (get a :watches) key nil) a)
|
|
(defn set-validator! [a f]
|
|
(jolt.host/ref-put! a :validator f) nil)
|
|
|
|
;; vreset!/vswap! live in the seq tier (10-seq.clj): its transducers use them.
|
|
|
|
;; Future status predicates — pure reads of the future's :cached/:cancelled slots.
|
|
;; future? stays native (deref/future-cancel/realized? call it); future-call and
|
|
;; future-cancel stay native too (OS threads).
|
|
(defn future-done? [x]
|
|
(if (future? x) (boolean (get x :cached)) (throw "future-done? requires a future")))
|
|
(defn future-cancelled? [x]
|
|
(and (future? x) (boolean (get x :cancelled))))
|
|
|
|
;; ns-name: a namespace object's :name as a symbol. Pure over get + symbol.
|
|
(defn ns-name [ns]
|
|
(let [nm (get ns :name)] (if nm (symbol (str nm)) nil)))
|
|
|
|
;; Java-array element access. Jolt arrays are mutable backing arrays; aget/alength
|
|
;; read them (nth/count) and aset writes a slot through ref-put!. Both handle the
|
|
;; multi-dimensional form (aget a i j ... / aset a i j ... v) by walking. The array
|
|
;; constructors (object-array/make-array/to-array/...) stay native — they build the
|
|
;; mutable backing.
|
|
(defn aget [arr & idxs]
|
|
(reduce (fn [v i] (nth v i)) arr idxs))
|
|
(defn alength [arr] (count arr))
|
|
(defn aset [arr & idxs+val]
|
|
(let [n (count idxs+val)
|
|
val (nth idxs+val (dec n))
|
|
target (reduce (fn [t k] (nth t k)) arr (take (- n 2) idxs+val))]
|
|
(jolt.host/ref-put! target (nth idxs+val (- n 2)) val)
|
|
val))
|
|
|
|
;; --- Phase 2 leaf batch (jolt-ded): fn combinators + host-free stubs ---------
|
|
|
|
(defn complement
|
|
"Takes a fn f and returns a fn that takes the same arguments as f, has the
|
|
same effects, if any, and returns the opposite truth value."
|
|
[f]
|
|
(fn [& args] (not (apply f args))))
|
|
|
|
;; Canonical Clojure fnil: patches only the FIRST 1-3 arguments (the old Janet
|
|
;; kernel patched every position it had a default for, which Clojure does not).
|
|
(defn fnil
|
|
([f x]
|
|
(fn [a & args] (apply f (if (nil? a) x a) args)))
|
|
([f x y]
|
|
(fn [a b & args] (apply f (if (nil? a) x a) (if (nil? b) y b) args)))
|
|
([f x y z]
|
|
(fn [a b c & args]
|
|
(apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) args))))
|
|
|
|
(defn clojure-version [] "1.11.0-jolt")
|
|
|
|
;; Jolt numbers are doubles; no BigDecimal, no ratios.
|
|
(defn bigdec [x] (* 1.0 x))
|
|
(defn numerator [x] (throw (ex-info "numerator requires a ratio (Jolt has no ratios)" {})))
|
|
(defn denominator [x] (throw (ex-info "denominator requires a ratio (Jolt has no ratios)" {})))
|
|
|
|
;; No class hierarchy on the Janet host.
|
|
(defn supers [x] #{})
|
|
|
|
;; Like Clojure's munge: rewrite dashes to underscores, preserving the argument's
|
|
;; type — a symbol munges to a symbol, anything else to a string. (jolt only
|
|
;; rewrites dashes, not the full Compiler CHAR_MAP.)
|
|
(defn munge [s]
|
|
(let [m (str-replace-all "-" "_" (str s))]
|
|
(if (symbol? s) (symbol m) m)))
|
|
|
|
(defn test
|
|
"Calls the :test fn from v's metadata; :ok if it runs, :no-test if absent."
|
|
[v]
|
|
(let [t (:test (meta v))]
|
|
(if t (do (t) :ok) :no-test)))
|
|
|
|
;; --- Phase 2 leaf batch 2 (jolt-ded): canonical Clojure ports ----------------
|
|
;; key/val/find first — merge-with and memoize below use them.
|
|
|
|
;; Strict, as in Clojure: an entry is what (seq m) yields (a host tuple), NOT
|
|
;; a plain vector — (key [1 2]) throws.
|
|
;; key/val moved above the hierarchies section (underive uses them).
|
|
|
|
;; find was previously missing from jolt entirely. Presence (contains?), not
|
|
;; value, decides — so (find {:a nil} :a) is [:a nil]. Works on vectors by
|
|
;; index. The result must be a REAL entry (key/val are strict), so it is
|
|
;; minted as the first entry of a one-entry map — nil values survive (the
|
|
;; map builder switches to a phm when nil is involved).
|
|
(defn find [m k]
|
|
(when (contains? m k) (first {k (get m k)})))
|
|
|
|
;; some? lives in the top leaf block now (forward refs are errors).
|
|
(defn true? [x] (= true x))
|
|
(defn false? [x] (= false x))
|
|
|
|
;; Presence-preserving: a key with a nil value is kept ((hash-map) base keeps
|
|
;; nil values and canonicalizes collection keys).
|
|
(defn select-keys [map keyseq]
|
|
(reduce (fn [m k] (if (contains? map k) (assoc m k (get map k)) m))
|
|
(hash-map) keyseq))
|
|
|
|
(defn zipmap [keys vals]
|
|
(loop [m (hash-map) ks (seq keys) vs (seq vals)]
|
|
(if (and ks vs)
|
|
(recur (assoc m (first ks) (first vs)) (next ks) (next vs))
|
|
m)))
|
|
|
|
;; conj semantics per entry arg (a map merges, a [k v] pair adds); nil args are
|
|
;; no-ops; all-nil (or no args) is nil.
|
|
(defn merge [& maps]
|
|
(when (some identity maps)
|
|
(reduce (fn [acc m] (if (nil? m) acc (conj (or acc (hash-map)) m)))
|
|
maps)))
|
|
|
|
(defn merge-with [f & maps]
|
|
(when (some identity maps)
|
|
(let [merge-entry (fn [m e]
|
|
(let [k (key e) v (val e)]
|
|
;; presence — not nil-of-value — decides combination
|
|
(if (contains? m k)
|
|
(assoc m k (f (get m k) v))
|
|
(assoc m k v))))
|
|
merge2 (fn [m1 m2]
|
|
(reduce merge-entry (or m1 (hash-map)) (seq m2)))]
|
|
(reduce merge2 maps))))
|
|
|
|
(defn get-in
|
|
([m ks] (reduce get m ks))
|
|
([m ks not-found]
|
|
;; a fresh table is its own identity — a present-but-nil step is
|
|
;; distinguished from a missing one
|
|
(let [sentinel (hash-map)]
|
|
(loop [m m ks (seq ks)]
|
|
(if ks
|
|
(let [nxt (get m (first ks) sentinel)]
|
|
(if (identical? sentinel nxt)
|
|
not-found
|
|
(recur nxt (next ks))))
|
|
m)))))
|
|
|
|
;; find-based, so nil RESULTS are cached too (the old kernel fn re-computed
|
|
;; them); args canonicalize as a collection key.
|
|
(defn memoize [f]
|
|
(let [mem (atom (hash-map))]
|
|
(fn [& args]
|
|
;; plain let/if, not if-let: this tier loads before 30-macros defines it
|
|
(let [e (find (deref mem) args)]
|
|
(if e
|
|
(val e)
|
|
(let [ret (apply f args)]
|
|
(swap! mem assoc args ret)
|
|
ret))))))
|
|
|
|
(defn partial
|
|
([f] f)
|
|
([f a] (fn [& args] (apply f a args)))
|
|
([f a b] (fn [& args] (apply f a b args)))
|
|
([f a b c] (fn [& args] (apply f a b c args)))
|
|
([f a b c & more] (fn [& args] (apply f a b c (concat more args)))))
|
|
|
|
(defn trampoline
|
|
([f] (let [ret (f)] (if (fn? ret) (trampoline ret) ret)))
|
|
([f & args] (trampoline (fn [] (apply f args)))))
|
|
|
|
;; Canonical pairwise max/min: > / < throw on non-numbers, and the NaN
|
|
;; behavior is Clojure's by construction.
|
|
(defn max
|
|
([x] x)
|
|
([x y] (if (> x y) x y))
|
|
([x y & more] (reduce max (max x y) more)))
|
|
|
|
(defn min
|
|
([x] x)
|
|
([x y] (if (< x y) x y))
|
|
([x y & more] (reduce min (min x y) more)))
|
|
|
|
(defn reverse [coll] (reduce conj (list) coll))
|
|
|
|
;; --- Phase 2 leaf batch 3 (jolt-ded) -----------------------------------------
|
|
|
|
;; An empty coll of the same category; sorted colls keep their comparator (the
|
|
;; value's own :empty op). Strings and scalars are nil, as in Clojure; a lazy
|
|
;; seq empties to () (the old kernel fn returned a host table for it).
|
|
(defn empty [coll]
|
|
(cond
|
|
(nil? coll) nil
|
|
(sorted? coll) ((get (jolt.host/ref-get coll :ops) :empty) coll)
|
|
(map? coll) {}
|
|
(set? coll) #{}
|
|
(vector? coll) []
|
|
(coll? coll) ()
|
|
:else nil))
|
|
|
|
(defn assoc-in [m [k & ks] v]
|
|
(if ks
|
|
(assoc m k (assoc-in (get m k) ks v))
|
|
(assoc m k v)))
|
|
|
|
(defn update-in [m ks f & args]
|
|
(let [up (fn up [m ks f args]
|
|
(let [[k & ks] ks]
|
|
(if ks
|
|
(assoc m k (up (get m k) ks f args))
|
|
(assoc m k (apply f (get m k) args)))))]
|
|
(up m ks f args)))
|
|
|
|
;; --- jolt-brh: the last missing-portable vars --------------------------------
|
|
|
|
;; jolt keywords have no intern table (any keyword "exists"), so find-keyword
|
|
;; always finds — babashka makes the same call.
|
|
(defn find-keyword
|
|
([nm] (keyword nm))
|
|
([ns nm] (keyword ns nm)))
|
|
|
|
;; The raw Inst protocol method; jolt insts have one representation, so it is
|
|
;; inst-ms itself.
|
|
(defn inst-ms* [i] (inst-ms i))
|
|
|
|
;; Canonical comp — here rather than the seed so each stage is invoked with
|
|
;; jolt call semantics: (comp seq :content) works because the keyword stage
|
|
;; goes through IFn dispatch (raw Janet keyword application does not).
|
|
(defn comp
|
|
([] identity)
|
|
([f] f)
|
|
([f g]
|
|
;; fixed arities first (Clojure's own shape): the 1-arg path — every
|
|
;; map/filter stage — is two direct calls, no rest-seq, no apply.
|
|
(fn
|
|
([] (f (g)))
|
|
([x] (f (g x)))
|
|
([x y] (f (g x y)))
|
|
([x y z] (f (g x y z)))
|
|
([x y z & args] (f (apply g x y z args)))))
|
|
([f g & fs] (reduce comp (comp f g) fs)))
|
|
|
|
;; Canonical IFn set (jolt-1vx): fns, keywords, symbols, maps (sorted incl.),
|
|
;; sets, vectors, and vars — NOT lists ((ifn? '(1 2)) is false in Clojure).
|
|
;; Mutable-mode caveat: vectors and lists share the array representation
|
|
;; there, so vector? can't separate them and lists read as ifn?.
|
|
(defn ifn? [x]
|
|
(or (fn? x) (keyword? x) (symbol? x) (map? x) (set? x) (vector? x) (var? x)))
|
|
|
|
;; Auto-promoting (') and unchecked arithmetic. Jolt numbers don't overflow,
|
|
;; so all of these are the checked ops; fixed arities mirror Clojure's
|
|
;; signatures. unchecked-divide-int goes through quot, so dividing by zero
|
|
;; throws as on the JVM (the old seed fn silently truncated infinity).
|
|
(def +' +)
|
|
(def -' -)
|
|
(def *' *)
|
|
(def inc' inc)
|
|
(def dec' dec)
|
|
(defn unchecked-add [x y] (+ x y))
|
|
(defn unchecked-subtract [x y] (- x y))
|
|
(defn unchecked-multiply [x y] (* x y))
|
|
(defn unchecked-negate [x] (- x))
|
|
(defn unchecked-inc [x] (+ x 1))
|
|
(defn unchecked-dec [x] (- x 1))
|
|
(def unchecked-add-int unchecked-add)
|
|
(def unchecked-subtract-int unchecked-subtract)
|
|
(def unchecked-multiply-int unchecked-multiply)
|
|
(def unchecked-negate-int unchecked-negate)
|
|
(def unchecked-inc-int unchecked-inc)
|
|
(def unchecked-dec-int unchecked-dec)
|
|
(defn unchecked-divide-int [x y] (quot x y))
|
|
(defn unchecked-remainder-int [x y] (rem x y))
|
|
(defn unchecked-int [x] (int x))
|
|
(def unchecked-long unchecked-int)
|
|
|
|
;; int? is integer? on jolt: one number type, so fixed-precision and
|
|
;; arbitrary-precision integers coincide.
|
|
(defn int? [x] (integer? x))
|
|
|
|
;; num: Clojure coerces to java.lang.Number; jolt just checks.
|
|
(defn num [x]
|
|
(if (number? x) x (throw (str "num requires a number, got: " x))))
|
|
|
|
;; == numeric equality: 1-arity is trivially true without inspecting the value
|
|
;; (Clojure's shape); 2+ args must be numbers, as Numbers.equiv throws.
|
|
(defn ==
|
|
([x] true)
|
|
([x y]
|
|
(if (and (number? x) (number? y))
|
|
(= x y)
|
|
(throw (str "Cannot cast to number: " (if (number? x) y x)))))
|
|
([x y & more]
|
|
(if (== x y)
|
|
(apply == y more)
|
|
false)))
|
|
|
|
;; ensure-reduced / halt-when: canonical Clojure. halt-when smuggles the halt
|
|
;; value through reduce in a ::halt-keyed map and unwraps it in the completion
|
|
;; arity, so the halt REPLACES the whole reduction result.
|
|
(defn ensure-reduced [x] (if (reduced? x) x (reduced x)))
|
|
|
|
(defn halt-when
|
|
([pred] (halt-when pred nil))
|
|
([pred retf]
|
|
(fn [rf]
|
|
(fn
|
|
([] (rf))
|
|
([result]
|
|
(if (and (map? result) (contains? result ::halt))
|
|
(get result ::halt)
|
|
(rf result)))
|
|
([result input]
|
|
(if (pred input)
|
|
(reduced (hash-map ::halt (if retf (retf (rf result) input) input)))
|
|
(rf result input)))))))
|
|
|
|
;; parse-boolean: exact "true"/"false" only; nil on anything else, throw on a
|
|
;; non-string (Clojure 1.11).
|
|
(defn parse-boolean [s]
|
|
(if (string? s)
|
|
(cond (= s "true") true (= s "false") false :else nil)
|
|
(throw (str "parse-boolean requires a string, got: " s))))
|
|
|
|
(defn newline [] (print "\n") nil)
|
|
|
|
;; seque: jolt is single-threaded eager here — the queue is a no-op and the
|
|
;; coll passes through.
|
|
(defn seque
|
|
([s] s)
|
|
([n-or-q s] s))
|
|
|
|
(defn array-seq [arr & _] (seq arr))
|
|
|
|
(defn to-array-2d [coll] (to-array (map to-array coll)))
|
|
|
|
;; Masking integer coercions (not aliases): byte/short wrap to their width.
|
|
;; unchecked-char keeps jolt's historical NUMBER result (Clojure returns a
|
|
;; char) — the char wrapper is a different value type here. int handles chars,
|
|
;; so (unchecked-byte \a) works as on the JVM.
|
|
(defn unchecked-byte [x] (bit-and (int x) 0xff))
|
|
(defn unchecked-short [x] (bit-and (int x) 0xffff))
|
|
(defn unchecked-char [x] (bit-and (int x) 0xffff))
|
|
(defn unchecked-float [x] (double x))
|
|
(defn unchecked-double [x] (double x))
|
|
|
|
;; --- transduce / into / eduction (seed-shrink round 5) ---------------------
|
|
;; Canonical transduce: build the stacked rf once, reduce (which honors
|
|
;; `reduced` and steps lazy seqs incrementally), then run the completion arity.
|
|
(defn transduce
|
|
([xform f coll] (transduce xform f (f) coll))
|
|
([xform f init coll]
|
|
(let [xf (xform f)]
|
|
(xf (reduce xf init coll)))))
|
|
|
|
;; into stays in the seed: it's perf-wall hot (the into-vec bench pays ~11%
|
|
;; through the overlay call layers — same lesson as even?/odd? in round 4).
|
|
|
|
;; eduction is EAGER on jolt (documented divergence, as before): the composed
|
|
;; xforms applied to coll, realized into a vector.
|
|
(defn eduction [& args]
|
|
(let [coll (last args)
|
|
xforms (butlast args)]
|
|
(if xforms
|
|
(into [] (apply comp xforms) coll)
|
|
(into [] coll))))
|
|
|
|
(defn ->Eduction [xform coll] (into [] xform coll))
|
|
|
|
;; --- JVM-shape stubs and trivial shells (seed-shrink batch 2) --------------
|
|
;; Pure compositions or documented jolt stubs; the host keeps nothing.
|
|
(defn enumeration-seq [e] (seq e))
|
|
(defn iterator-seq [i] (seq i))
|
|
|
|
;; jolt is single-threaded: a promise is an atom, deref never blocks
|
|
;; ((deref undelivered) is nil rather than a hang).
|
|
(defn promise [] (atom nil))
|
|
(defn deliver [p v] (reset! p v) p)
|
|
|
|
(defn bean [x] (if (map? x) x {}))
|
|
|
|
(defn uri? [x] false)
|
|
|
|
;; An EVALUATED set of quoted symbols — a quoted set literal ('#{if ...})
|
|
;; stays an unevaluated reader form on jolt and contains? can't see into it.
|
|
(def ^:private special-syms
|
|
#{'if 'do 'let* 'fn* 'quote 'var 'def 'loop* 'recur 'throw 'try 'catch
|
|
'finally 'new 'set! '. 'monitor-enter 'monitor-exit})
|
|
|
|
(defn special-symbol? [s] (contains? special-syms s))
|
|
|
|
;; print-method / print-dup are real multimethods in the io tier (50-io.clj).
|
|
|
|
;; JVM proxies don't exist on a Janet host: the read-only surface is inert,
|
|
;; the constructive surface throws (matching the prior seed stubs).
|
|
(defn proxy-mappings [p] {})
|
|
(defn proxy-call-with-super [f p meth] (f))
|
|
(defn init-proxy [p mappings] p)
|
|
(defn update-proxy [p mappings] p)
|
|
(defn proxy-super [& args] (throw "proxy-super: JVM proxies are not supported in Jolt"))
|
|
(defn construct-proxy [c & args] (throw "construct-proxy: not supported in Jolt"))
|
|
(defn get-proxy-class [& interfaces] (throw "get-proxy-class: not supported in Jolt"))
|